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.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 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
#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 :: [S.ByteString]
, 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 ActionState = ActionState
{ actionResponse :: Response
, actionStatus :: Status
, actionHeaders :: ResponseHeaders
, actionReqBody :: Maybe ([Param], [File])
, actionPathInfo :: [T.Text]
}
initialState :: ApiaryConfig -> Request -> ActionState
initialState conf req = ActionState
{ actionResponse = responseLBS (defaultStatus conf) (defaultHeaders conf) ""
, actionStatus = defaultStatus conf
, actionHeaders = defaultHeaders conf
, actionReqBody = Nothing
, actionPathInfo = pathInfo req
}
data ActionEnv = ActionEnv
{ actionConfig :: ApiaryConfig
, actionRequest :: Request
, actionDocuments :: Documents
}
data Action a
= Continue 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, ActionState))
runActionT m env st = unActionT m env st $ \a st' ->
st' `seq` return (Continue (a, st'))
actionT :: Monad m
=> (ActionEnv -> ActionState -> m (Action (a, ActionState)))
-> ActionT m a
actionT f = ActionT $ \env st cont -> f env st >>= \case
Pass -> return Pass
Stop s -> return $ Stop s
Continue (a,st') -> st' `seq` 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 request) >>= \case
#ifdef WAI3
Pass -> notFound config request send
#else
Pass -> notFound config request
#endif
Stop s -> send s
Continue (_,r) -> send $ actionResponse r
instance Functor (ActionT m) where
fmap f m = ActionT $ \env st cont ->
unActionT m env st (\a s' -> s' `seq` 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'' ->
st' `seq` st'' `seq` 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' ->
st' `seq` 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 ->
catch (runActionT m env st) (\e -> runActionT (h e) env st)
instance MonadMask m => MonadMask (ActionT m) where
mask a = actionT $ \env st ->
mask $ \u -> runActionT (a $ q u) env st
where
q u m = actionT $ \env st -> u (runActionT m env st)
uninterruptibleMask a = actionT $ \env st ->
uninterruptibleMask $ \u -> runActionT (a $ q u) env st
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 -> runActionT m e s >>= \case
Continue a -> return $ Continue a
Stop stp -> return $ Stop stp
Pass -> runActionT n e s
instance MonadBase b m => MonadBase b (ActionT m) where
liftBase = liftBaseDefault
instance MonadTransControl ActionT where
newtype StT ActionT a = StActionT { unStActionT :: Action (a, ActionState) }
liftWith f = actionT $ \e s ->
liftM (\a -> Continue (a,s)) (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 (actionResponse 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 = f (actionStatus s) (actionHeaders s)} )
file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()
file' f p = rawResponse (\s h -> responseFile s h 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 = rawResponse (\s h -> responseBuilder s h b)
lbs :: Monad m => L.ByteString -> ActionT m ()
lbs l = rawResponse (\s h -> responseLBS s h l)
stream :: Monad m => StreamingBody -> ActionT m ()
#ifdef WAI3
stream str = rawResponse (\s h -> responseStream s h str)
#else
stream str = rawResponse (\s h -> responseSource s h str)
#endif
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