module Control.Monad.Apiary.Action.Internal where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Base
import Control.Monad.Reader
import Control.Monad.Catch
import Control.Monad.Trans.Control
import Network.Mime
import Network.HTTP.Types
import Network.Wai
import qualified Network.Wai.Parse as P
import Data.Monoid
import Data.Apiary.Param
import Data.Apiary.Document
import Data.Apiary.Document.Html
import Data.Default.Class
import Blaze.ByteString.Builder
import Text.Blaze.Html.Renderer.Utf8
import qualified Blaze.ByteString.Builder as B
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
#ifndef WAI3
import Data.Conduit
type StreamingBody = Source IO (Flush Builder)
#endif
data ApiaryConfig = ApiaryConfig
{
notFound :: Application
, defaultStatus :: Status
, defaultHeaders :: ResponseHeaders
, failStatus :: Status
, failHeaders :: ResponseHeaders
, rootPattern :: [T.Text]
, mimeType :: FilePath -> S.ByteString
}
defaultDocumentationAction :: Monad m => DefaultDocumentConfig -> ActionT m ()
defaultDocumentationAction conf = do
d <- getDocuments
contentType "text/html"
builder . renderHtmlBuilder $ defaultDocumentToHtml conf d
defaultNotFound :: Application
#ifdef WAI3
defaultNotFound _ f = f $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"
#else
defaultNotFound _ = return $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"
#endif
instance Default ApiaryConfig where
def = ApiaryConfig
{ notFound = defaultNotFound
, defaultStatus = ok200
, defaultHeaders = []
, failStatus = internalServerError500
, failHeaders = []
, rootPattern = ["index.html", "index.htm"]
, mimeType = defaultMimeLookup . T.pack
}
data ResponseBody
= ResponseFile FilePath (Maybe FilePart)
| ResponseBuilder Builder
| ResponseStream StreamingBody
| ResponseRaw (IO S.ByteString -> (S.ByteString -> IO ()) -> IO ()) Response
| ResponseFunc (Status -> ResponseHeaders -> Response)
instance Monoid ResponseBody where
mempty = ResponseBuilder mempty
ResponseBuilder a `mappend` ResponseBuilder b = ResponseBuilder $ a <> b
_ `mappend` b = b
toResponse :: ActionState -> Response
toResponse ActionState{..} = case actionResponse of
ResponseFile f p -> responseFile actionStatus actionHeaders f p
ResponseBuilder b -> responseBuilder actionStatus actionHeaders b
#ifdef WAI3
ResponseStream s -> responseStream actionStatus actionHeaders s
#else
ResponseStream s -> responseSource actionStatus actionHeaders s
#endif
ResponseRaw f r -> responseRaw f r
ResponseFunc f -> f actionStatus actionHeaders
data ActionState = ActionState
{ actionResponse :: ResponseBody
, actionStatus :: Status
, actionHeaders :: ResponseHeaders
, actionReqBody :: Maybe ([Param], [File])
, actionFetches :: [T.Text]
}
initialState :: ApiaryConfig -> ActionState
initialState conf = ActionState
{ actionResponse = ResponseBuilder mempty
, actionStatus = defaultStatus conf
, actionHeaders = defaultHeaders conf
, actionReqBody = Nothing
, actionFetches = []
}
data ActionEnv = ActionEnv
{ actionConfig :: ApiaryConfig
, actionRequest :: Request
, actionDocuments :: Documents
}
data Action a
= Continue ActionState a
| Pass
| Stop Response
newtype ActionT m a = ActionT { unActionT :: forall b.
ActionEnv
-> ActionState
-> (a -> ActionState -> m (Action b))
-> m (Action b)
}
runActionT :: Monad m => ActionT m a
-> ActionEnv -> ActionState
-> m (Action a)
runActionT m env st = unActionT m env st $ \a !st' ->
return (Continue st' a)
actionT :: Monad m
=> (ActionEnv -> ActionState -> m (Action a))
-> ActionT m a
actionT f = ActionT $ \env !st cont -> f env st >>= \case
Pass -> return Pass
Stop s -> return $ Stop s
Continue !st' a -> cont a st'
hoistActionT :: (Monad m, Monad n)
=> (forall b. m b -> n b) -> ActionT m a -> ActionT n a
hoistActionT run m = actionT $ \e s -> run (runActionT m e s)
execActionT :: ApiaryConfig -> Documents -> ActionT IO () -> Application
#ifdef WAI3
execActionT config doc m request send =
#else
execActionT config doc m request = let send = return in
#endif
runActionT m (ActionEnv config request doc) (initialState config) >>= \case
#ifdef WAI3
Pass -> notFound config request send
#else
Pass -> notFound config request
#endif
Stop s -> send s
Continue r _ -> send $ toResponse r
instance Functor (ActionT m) where
fmap f m = ActionT $ \env st cont ->
unActionT m env st (\a !s' -> cont (f a) s')
instance Applicative (ActionT m) where
pure x = ActionT $ \_ !st cont -> cont x st
mf <*> ma = ActionT $ \env st cont ->
unActionT mf env st $ \f !st' ->
unActionT ma env st' $ \a !st'' ->
cont (f a) st''
instance Monad m => Monad (ActionT m) where
return x = ActionT $ \_ !st cont -> cont x st
m >>= k = ActionT $ \env !st cont ->
unActionT m env st $ \a !st' ->
unActionT (k a) env st' cont
fail s = ActionT $ \(ActionEnv{actionConfig = c}) _ _ -> return $
Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s)
instance MonadIO m => MonadIO (ActionT m) where
liftIO m = ActionT $ \_ !st cont ->
liftIO m >>= \a -> cont a st
instance MonadTrans ActionT where
lift m = ActionT $ \_ !st cont ->
m >>= \a -> cont a st
instance MonadThrow m => MonadThrow (ActionT m) where
throwM e = ActionT $ \_ !st cont ->
throwM e >>= \a -> cont a st
instance MonadCatch m => MonadCatch (ActionT m) where
catch m h = ActionT $ \env !st cont ->
catch (unActionT m env st cont) (\e -> unActionT (h e) env st cont)
instance MonadMask m => MonadMask (ActionT m) where
mask a = ActionT $ \env !st cont ->
mask $ \u -> unActionT (a $ q u) env st cont
where
q u m = actionT $ \env !st -> u (runActionT m env st)
uninterruptibleMask a = ActionT $ \env !st cont ->
uninterruptibleMask $ \u -> unActionT (a $ q u) env st cont
where
q u m = actionT $ \env !st -> u (runActionT m env st)
instance (Monad m, Functor m) => Alternative (ActionT m) where
empty = mzero
(<|>) = mplus
instance Monad m => MonadPlus (ActionT m) where
mzero = ActionT $ \_ _ _ -> return Pass
mplus m n = ActionT $ \e !s cont -> unActionT m e s cont >>= \case
Continue !st a -> return $ Continue st a
Stop stp -> return $ Stop stp
Pass -> unActionT n e s cont
instance MonadBase b m => MonadBase b (ActionT m) where
liftBase = liftBaseDefault
instance MonadTransControl ActionT where
newtype StT ActionT a = StActionT { unStActionT :: Action a }
liftWith f = actionT $ \e !s ->
liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t e s)
restoreT m = actionT $ \_ _ -> liftM unStActionT m
instance MonadBaseControl b m => MonadBaseControl b (ActionT m) where
newtype StM (ActionT m) a = StMT { unStMT :: ComposeSt ActionT m a }
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
instance MonadReader r m => MonadReader r (ActionT m) where
ask = lift ask
local f = hoistActionT $ local f
getEnv :: Monad m => ActionT m ActionEnv
getEnv = ActionT $ \e s c -> c e s
getRequest :: Monad m => ActionT m Request
getRequest = liftM actionRequest getEnv
getConfig :: Monad m => ActionT m ApiaryConfig
getConfig = liftM actionConfig getEnv
getDocuments :: Monad m => ActionT m Documents
getDocuments = liftM actionDocuments getEnv
getRequestBody :: MonadIO m => ActionT m ([Param], [File])
getRequestBody = ActionT $ \e s c -> case actionReqBody s of
Just b -> c b s
Nothing -> do
(p,f) <- liftIO $ P.parseRequestBody P.lbsBackEnd (actionRequest e)
let b = (p, map convFile f)
c b s { actionReqBody = Just b }
where
convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent
getReqParams :: MonadIO m => ActionT m [Param]
getReqParams = fst <$> getRequestBody
getReqFiles :: MonadIO m => ActionT m [File]
getReqFiles = snd <$> getRequestBody
modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m ()
modifyState f = ActionT $ \_ s c -> c () (f s)
getState :: ActionT m ActionState
getState = ActionT $ \_ s c -> c s s
status :: Monad m => Status -> ActionT m ()
status st = modifyState (\s -> s { actionStatus = st } )
getHeaders :: Monad m => ActionT m RequestHeaders
getHeaders = requestHeaders `liftM` getRequest
modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT m ()
modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } )
addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT m ()
addHeader h v = modifyHeader ((h,v):)
setHeaders :: Monad m => ResponseHeaders -> ActionT m ()
setHeaders hs = modifyHeader (const hs)
type ContentType = S.ByteString
contentType :: Monad m => ContentType -> ActionT m ()
contentType c = modifyHeader
(\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h)
stop :: Monad m => ActionT m a
stop = ActionT $ \_ s _ -> return $ Stop (toResponse s)
stopWith :: Monad m => Response -> ActionT m a
stopWith a = ActionT $ \_ _ _ -> return $ Stop a
redirectWith :: Monad m
=> Status
-> S.ByteString
-> ActionT m ()
redirectWith st url = do
status st
addHeader "location" url
redirectPermanently :: Monad m => S.ByteString -> ActionT m ()
redirectPermanently = redirectWith movedPermanently301
redirect :: Monad m => S.ByteString -> ActionT m ()
redirect to = do
v <- httpVersion <$> getRequest
if v == http11
then redirectWith seeOther303 to
else redirectWith status302 to
redirectTemporary :: Monad m => S.ByteString -> ActionT m ()
redirectTemporary to = do
v <- httpVersion <$> getRequest
if v == http11
then redirectWith temporaryRedirect307 to
else redirectWith status302 to
rawResponse :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT m ()
rawResponse f = modifyState (\s -> s { actionResponse = ResponseFunc f } )
reset :: Monad m => ActionT m ()
reset = modifyState (\s -> s { actionResponse = mempty } )
file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()
file' f p = modifyState (\s -> s { actionResponse = ResponseFile f p } )
file :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()
file f p = do
mime <- mimeType <$> getConfig
contentType (mime f)
file' f p
builder :: Monad m => Builder -> ActionT m ()
builder b = modifyState (\s -> s { actionResponse = actionResponse s <> ResponseBuilder b } )
bytes :: Monad m => S.ByteString -> ActionT m ()
bytes = builder . B.fromByteString
lazyBytes :: Monad m => L.ByteString -> ActionT m ()
lazyBytes = builder . B.fromLazyByteString
text :: Monad m => T.Text -> ActionT m ()
text = builder . B.fromText
lazyText :: Monad m => TL.Text -> ActionT m ()
lazyText = builder . B.fromLazyText
showing :: (Monad m, Show a) => a -> ActionT m ()
showing = builder . B.fromShow
string :: Monad m => String -> ActionT m ()
string = builder . B.fromString
char :: Monad m => Char -> ActionT m ()
char = builder . B.fromChar
stream :: Monad m => StreamingBody -> ActionT m ()
stream str = modifyState (\s -> s { actionResponse = ResponseStream str })
source :: Monad m => StreamingBody -> ActionT m ()
source = stream
redirectFound :: Monad m => S.ByteString -> ActionT m ()
redirectFound = redirectWith found302
redirectSeeOther :: Monad m => S.ByteString -> ActionT m ()
redirectSeeOther = redirectWith seeOther303
lbs :: Monad m => L.ByteString -> ActionT m ()
lbs = lazyBytes