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
{ actionStatus :: Status
, actionHeaders :: ResponseHeaders
, actionBody :: Body
, actionReqBody :: Maybe ([Param], [File L.ByteString])
}
#ifndef WAI3
type StreamingBody = Source IO (Flush Builder)
#endif
data Body
= File FilePath (Maybe FilePart)
| Builder Builder
| LBS L.ByteString
| Str StreamingBody
actionStateToResponse :: ActionState -> Response
actionStateToResponse as = case actionBody as of
File f p -> responseFile st hd f p
Builder b -> responseBuilder st hd b
LBS l -> responseLBS st hd l
#ifdef WAI3
Str s -> responseStream st hd s
#else
Str s -> responseSource st hd s
#endif
where
st = actionStatus as
hd = actionHeaders as
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
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 = runActionT m config request resp >>= \case
Pass -> notFound config request send
Stop s -> send s
Continue (_,r) -> send $ actionStateToResponse r
where
resp = ActionState (defaultStatus config) (defaultHeader config) (LBS "") Nothing
#else
execActionT config m request = runActionT m config request resp >>= \case
Pass -> notFound config request
Stop s -> return s
Continue (_,r) -> return $ actionStateToResponse r
where
resp = ActionState (defaultStatus config) (defaultHeader config) (LBS "") Nothing
#endif
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 (actionStateToResponse 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)
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
file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()
file' f p = modifyState (\s -> s { actionBody = File f p } )
builder :: Monad m => Builder -> ActionT m ()
builder b = modifyState (\s -> s { actionBody = Builder b } )
lbs :: Monad m => L.ByteString -> ActionT m ()
lbs l = modifyState (\s -> s { actionBody = LBS l } )
stream :: Monad m => StreamingBody -> ActionT m ()
stream str = modifyState (\s -> s { actionBody = Str 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