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 :: [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 ActionState = ActionState
{ actionResponse :: Response
, actionStatus :: Status
, actionHeaders :: ResponseHeaders
, actionReqBody :: Maybe ([Param], [File])
, actionFetches :: [T.Text]
}
initialState :: ApiaryConfig -> ActionState
initialState conf = ActionState
{ actionResponse = responseLBS (defaultStatus conf) (defaultHeaders conf) ""
, 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
deriving (Functor)
newtype ActionT m a = ActionT { runActionT ::
ActionEnv
-> ActionState
-> m (Action a)
}
hoistActionT :: (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 $ actionResponse r
instance Functor m => Functor (ActionT m) where
fmap f m = ActionT $ \env st ->
fmap f <$> runActionT m env st
instance (Functor m, Monad m) => Applicative (ActionT m) where
pure x = ActionT $ \_ s -> return $ Continue s x
mf <*> ma = ActionT $ \env st ->
runActionT mf env st >>= \case
Pass -> return Pass
Stop r -> return $ Stop r
Continue st' f -> runActionT ma env st' >>= \case
Continue st'' a -> return $ Continue st'' (f a)
Pass -> return Pass
Stop r -> return $ Stop r
instance Monad m => Monad (ActionT m) where
return x = ActionT $ \_ st -> return $ Continue st x
m >>= k = ActionT $ \env st ->
runActionT m env st >>= \case
Pass -> return Pass
Stop r -> return $ Stop r
Continue st' a -> runActionT (k a) env st' >>= \case
Pass -> return Pass
Stop r -> return $ Stop r
Continue st'' b -> return $ Continue st'' b
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 ->
Continue st `liftM` liftIO m
instance MonadTrans ActionT where
lift m = ActionT $ \_ st ->
Continue st `liftM` m
instance MonadThrow m => MonadThrow (ActionT m) where
throwM e = ActionT $ \_ st ->
Continue st `liftM` throwM e
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 st a -> return $ Continue st 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 }
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 st -> return $ Continue st e
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 -> case actionReqBody s of
Just b -> return $ Continue s b
Nothing -> do
(p,f) <- liftIO $ P.parseRequestBody P.lbsBackEnd (actionRequest e)
let b = (p, map convFile f)
return $ Continue s { actionReqBody = Just b } b
where
convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent
getReqParams :: MonadIO m => ActionT m [Param]
getReqParams = fst `liftM` getRequestBody
getReqFiles :: MonadIO m => ActionT m [File]
getReqFiles = snd `liftM` getRequestBody
modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m ()
modifyState f = ActionT $ \_ s -> return $ Continue (f s) ()
getState :: Monad m => ActionT m ActionState
getState = ActionT $ \_ s -> return $ Continue 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 `liftM` getRequest
if v == http11
then redirectWith seeOther303 to
else redirectWith status302 to
redirectTemporary :: Monad m => S.ByteString -> ActionT m ()
redirectTemporary to = do
v <- httpVersion `liftM` 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 `liftM` 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