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 Network.Wai.Parse
import Network.Mime
import Data.Default.Class
import Network.HTTP.Types
import Blaze.ByteString.Builder
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
#ifndef WAI3
import Data.Conduit
#endif
data ApiaryConfig = ApiaryConfig
{
notFound :: Application
, defaultStatus :: Status
, defaultHeader :: ResponseHeaders
, rootPattern :: [S.ByteString]
, mimeType :: FilePath -> S.ByteString
}
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
, defaultHeader = []
, rootPattern = ["", "/", "/index.html", "/index.htm"]
, mimeType = defaultMimeLookup . T.pack
}
data ActionState
= ActionState
{ actionResponse :: Response
, actionStatus :: Status
, actionHeaders :: ResponseHeaders
, actionReqBody :: Maybe ([Param], [File L.ByteString])
, actionPathInfo :: [T.Text]
}
initialState :: ApiaryConfig -> Request -> ActionState
initialState conf req = ActionState
{ actionResponse = responseLBS (defaultStatus conf) (defaultHeader conf) ""
, actionStatus = defaultStatus conf
, actionHeaders = defaultHeader 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 _ = ActionT $ \_ _ _ _ -> return Pass
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 L.ByteString])
getRequestBody = ActionT $ \_ r s c -> case actionReqBody s of
Just b -> c b s
Nothing -> do
b <- liftIO $ parseRequestBody lbsBackEnd r
c b s { actionReqBody = Just b }
getReqParams :: MonadIO m => ActionT m [Param]
getReqParams = fst <$> getRequestBody
getReqFiles :: MonadIO m => ActionT m [File L.ByteString]
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)
contentType :: Monad m => S.ByteString -> 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