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.Wai
import qualified Network.Wai.Parse as P
import Network.Mime
import Network.HTTP.Types
import Data.Apiary.Param
import Data.Apiary.Document
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
#endif
data ApiaryConfig = ApiaryConfig
{
notFound :: Application
, defaultStatus :: Status
, defaultHeaders :: ResponseHeaders
, failStatus :: Status
, failHeaders :: ResponseHeaders
, rootPattern :: [S.ByteString]
, mimeType :: FilePath -> S.ByteString
, documentationAction :: Maybe (Documents -> ActionT IO ())
}
defaultDocumentationAction :: Monad m => S.ByteString -> DefaultDocumentConfig -> Documents -> ActionT m ()
defaultDocumentationAction r conf d = do
p <- rawPathInfo <$> getRequest
guard $ p == r
contentType "text/html"
builder . renderHtmlBuilder $ defaultDocumentToHtml conf d
defNotFound :: Application
#ifdef WAI3
defNotFound _ f = f $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"
#else
defNotFound _ = return $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"
#endif
instance Default ApiaryConfig where
def = ApiaryConfig
{ notFound = defNotFound
, defaultStatus = ok200
, defaultHeaders = []
, failStatus = internalServerError500
, failHeaders = []
, rootPattern = ["", "/", "/index.html", "/index.htm"]
, mimeType = defaultMimeLookup . T.pack
, documentationAction = Just $ defaultDocumentationAction
"/api/documentation" def
}
convFile :: (S.ByteString, P.FileInfo L.ByteString) -> File
convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent
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
}
#ifndef WAI3
type StreamingBody = Source IO (Flush Builder)
#endif
data Action a
= Continue a
| Pass
| Stop Response
newtype ActionT m a = ActionT { unActionT :: forall b.
ApiaryConfig
-> Request
-> ActionState
-> (a -> ActionState -> m (Action b))
-> m (Action b)
}
instance Functor (ActionT m) where
fmap f m = ActionT $ \conf req st cont ->
unActionT m conf req 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 $ \conf req st cont ->
unActionT mf conf req st $ \f st' ->
unActionT ma conf req 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 $ \conf req st cont ->
unActionT m conf req st $ \a st' ->
st' `seq` unActionT (k a) conf req st' cont
fail s = ActionT $ \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 $ \conf req st ->
catch (runActionT m conf req st) (\e -> runActionT (h e) conf req st)
instance MonadMask m => MonadMask (ActionT m) where
mask a = actionT $ \conf req st ->
mask $ \u -> runActionT (a $ q u) conf req st
where
q u m = actionT $ \conf req st -> u (runActionT m conf req st)
uninterruptibleMask a = actionT $ \conf req st ->
uninterruptibleMask $ \u -> runActionT (a $ q u) conf req st
where
q u m = actionT $ \conf req st -> u (runActionT m conf req st)
runActionT :: Monad m => ActionT m a
-> ApiaryConfig -> Request -> ActionState
-> m (Action (a, ActionState))
runActionT m conf req st = unActionT m conf req st $ \a st' ->
st' `seq` return (Continue (a, st'))
actionT :: Monad m
=> (ApiaryConfig -> Request -> ActionState -> m (Action (a, ActionState)))
-> ActionT m a
actionT f = ActionT $ \conf req st cont -> f conf req 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 $ \c r s -> run (runActionT m c r s)
execActionT :: ApiaryConfig -> ActionT IO () -> Application
#ifdef WAI3
execActionT config m request send =
#else
execActionT config m request = let send = return in
#endif
runActionT m config request (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 (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 $ \c r s -> runActionT m c r s >>= \case
Continue a -> return $ Continue a
Stop stp -> return $ Stop stp
Pass -> runActionT n c r 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 $ \c r s ->
liftM (\a -> Continue (a,s)) (f $ \t -> liftM StActionT $ runActionT t c r 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
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
getRequest :: Monad m => ActionT m Request
getRequest = ActionT $ \_ r s c -> c r s
getRequestBody :: MonadIO m => ActionT m ([Param], [File])
getRequestBody = ActionT $ \_ r s c -> case actionReqBody s of
Just b -> c b s
Nothing -> do
(p,f) <- liftIO $ P.parseRequestBody P.lbsBackEnd r
let b = (p, map convFile f)
c b s { actionReqBody = Just b }
getReqParams :: MonadIO m => ActionT m [Param]
getReqParams = fst <$> getRequestBody
getReqFiles :: MonadIO m => ActionT m [File]
getReqFiles = snd <$> getRequestBody
getConfig :: Monad m => ActionT m ApiaryConfig
getConfig = ActionT $ \c _ s cont -> cont c s
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
getHeaders :: Monad m => ActionT m RequestHeaders
getHeaders = requestHeaders `liftM` getRequest
status :: Monad m => Status -> ActionT m ()
status st = modifyState (\s -> s { actionStatus = st } )
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)
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
file :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()
file f p = do
mime <- mimeType <$> getConfig
contentType (mime f)
file' f p
response :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT m ()
response f = modifyState (\s -> s { actionResponse = f (actionStatus s) (actionHeaders s)} )
file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()
file' f p = response (\s h -> responseFile s h f p)
builder :: Monad m => Builder -> ActionT m ()
builder b = response (\s h -> responseBuilder s h b)
lbs :: Monad m => L.ByteString -> ActionT m ()
lbs l = response (\s h -> responseLBS s h l)
stream :: Monad m => StreamingBody -> ActionT m ()
#ifdef WAI3
stream str = response (\s h -> responseStream s h str)
#else
stream str = response (\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