module Control.Monad.Apiary.Action.Internal where
import System.PosixCompat.Files
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 hiding (Extension)
import Network.HTTP.Date
import Network.HTTP.Types
import Network.Wai
import qualified Network.Wai.Parse as P
import Data.Monoid hiding (All)
import Data.Apiary.Extension
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 Blaze.ByteString.Builder as B
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
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
import qualified Data.Text.Lazy as TL
#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 exts 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 ResponseBody
= ResponseFile FilePath (Maybe FilePart)
| ResponseBuilder Builder
| ResponseStream StreamingBody
| ResponseRaw (IO S.ByteString -> (S.ByteString -> IO ()) -> IO ()) Response
| ResponseFunc (Status -> ResponseHeaders -> Response)
instance Monoid ResponseBody where
mempty = ResponseBuilder mempty
ResponseBuilder a `mappend` ResponseBuilder b = ResponseBuilder $ a <> b
_ `mappend` b = b
toResponse :: ActionState -> Response
toResponse ActionState{..} = case actionResponse of
ResponseFile f p -> responseFile actionStatus actionHeaders f p
ResponseBuilder b -> responseBuilder actionStatus actionHeaders b
#ifdef WAI3
ResponseStream s -> responseStream actionStatus actionHeaders s
#else
ResponseStream s -> responseSource actionStatus actionHeaders s
#endif
ResponseRaw f r -> responseRaw f r
ResponseFunc f -> f actionStatus actionHeaders
data ActionState = ActionState
{ actionResponse :: ResponseBody
, actionStatus :: Status
, actionHeaders :: ResponseHeaders
, actionReqBody :: Maybe ([Param], [File])
, actionFetches :: [T.Text]
}
initialState :: ApiaryConfig -> ActionState
initialState conf = ActionState
{ actionResponse = ResponseBuilder mempty
, actionStatus = defaultStatus conf
, actionHeaders = defaultHeaders conf
, actionReqBody = Nothing
, actionFetches = []
}
data ActionEnv exts = ActionEnv
{ actionConfig :: ApiaryConfig
, actionRequest :: Request
, actionDocuments :: Documents
, actionExts :: Extensions exts
}
data Action a
= Continue ActionState a
| Pass
| Stop Response
newtype ActionT exts m a = ActionT { unActionT :: forall b.
ActionEnv exts
-> ActionState
-> (a -> ActionState -> m (Action b))
-> m (Action b)
}
runActionT :: Monad m => ActionT exts m a
-> ActionEnv exts -> ActionState
-> m (Action a)
runActionT m env st = unActionT m env st $ \a !st' ->
return (Continue st' a)
actionT :: Monad m
=> (ActionEnv exts -> ActionState -> m (Action a))
-> ActionT exts m a
actionT f = ActionT $ \env !st cont -> f env st >>= \case
Pass -> return Pass
Stop s -> return $ Stop s
Continue !st' a -> cont a st'
hoistActionT :: (Monad m, Monad n)
=> (forall b. m b -> n b) -> ActionT exts m a -> ActionT exts n a
hoistActionT run m = actionT $ \e s -> run (runActionT m e s)
execActionT :: ApiaryConfig -> Extensions exts -> Documents -> ActionT exts IO () -> Application
#ifdef WAI3
execActionT config exts doc m request send =
#else
execActionT config exts doc m request = let send = return in
#endif
runActionT m (ActionEnv config request doc exts) (initialState config) >>= \case
#ifdef WAI3
Pass -> notFound config request send
#else
Pass -> notFound config request
#endif
Stop s -> send s
Continue r _ -> send $ toResponse r
instance Functor (ActionT exts m) where
fmap f m = ActionT $ \env st cont ->
unActionT m env st (\a !s' -> cont (f a) s')
instance Applicative (ActionT exts 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'' ->
cont (f a) st''
instance Monad m => Monad (ActionT exts m) where
return x = ActionT $ \_ !st cont -> cont x st
m >>= k = ActionT $ \env !st cont ->
unActionT m env st $ \a !st' ->
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 exts m) where
liftIO m = ActionT $ \_ !st cont ->
liftIO m >>= \a -> cont a st
instance MonadTrans (ActionT exts) where
lift m = ActionT $ \_ !st cont ->
m >>= \a -> cont a st
instance MonadThrow m => MonadThrow (ActionT exts m) where
throwM e = ActionT $ \_ !st cont ->
throwM e >>= \a -> cont a st
instance MonadCatch m => MonadCatch (ActionT exts m) where
catch m h = ActionT $ \env !st cont ->
catch (unActionT m env st cont) (\e -> unActionT (h e) env st cont)
instance MonadMask m => MonadMask (ActionT exts m) where
mask a = ActionT $ \env !st cont ->
mask $ \u -> unActionT (a $ q u) env st cont
where
q u m = actionT $ \env !st -> u (runActionT m env st)
uninterruptibleMask a = ActionT $ \env !st cont ->
uninterruptibleMask $ \u -> unActionT (a $ q u) env st cont
where
q u m = actionT $ \env !st -> u (runActionT m env st)
instance (Monad m, Functor m) => Alternative (ActionT exts m) where
empty = mzero
(<|>) = mplus
instance Monad m => MonadPlus (ActionT exts m) where
mzero = ActionT $ \_ _ _ -> return Pass
mplus m n = ActionT $ \e !s cont -> unActionT m e s cont >>= \case
Continue !st a -> return $ Continue st a
Stop stp -> return $ Stop stp
Pass -> unActionT n e s cont
instance MonadBase b m => MonadBase b (ActionT exts m) where
liftBase = liftBaseDefault
instance MonadTransControl (ActionT exts) where
newtype StT (ActionT exts) 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 exts m) where
newtype StM (ActionT exts m) a = StMT { unStMT :: ComposeSt (ActionT exts) m a }
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
instance MonadReader r m => MonadReader r (ActionT exts m) where
ask = lift ask
local f = hoistActionT $ local f
getEnv :: Monad m => ActionT exts m (ActionEnv exts)
getEnv = ActionT $ \e s c -> c e s
getRequest :: Monad m => ActionT exts m Request
getRequest = liftM actionRequest getEnv
getConfig :: Monad m => ActionT exts m ApiaryConfig
getConfig = liftM actionConfig getEnv
getExt :: (Has e exts, Monad m) => proxy e -> ActionT exts m e
getExt p = liftM (getExtension p . actionExts) getEnv
getDocuments :: Monad m => ActionT exts m Documents
getDocuments = liftM actionDocuments getEnv
getRequestBody :: MonadIO m => ActionT exts 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 exts m [Param]
getReqParams = fst <$> getRequestBody
getReqFiles :: MonadIO m => ActionT exts m [File]
getReqFiles = snd <$> getRequestBody
modifyState :: Monad m => (ActionState -> ActionState) -> ActionT exts m ()
modifyState f = ActionT $ \_ s c -> c () (f s)
getState :: ActionT exts m ActionState
getState = ActionT $ \_ s c -> c s s
status :: Monad m => Status -> ActionT exts m ()
status st = modifyState (\s -> s { actionStatus = st } )
getHeaders :: Monad m => ActionT exts m RequestHeaders
getHeaders = requestHeaders `liftM` getRequest
modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT exts m ()
modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } )
addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT exts m ()
addHeader h v = modifyHeader ((h,v):)
setHeaders :: Monad m => ResponseHeaders -> ActionT exts m ()
setHeaders hs = modifyHeader (const hs)
type ContentType = S.ByteString
contentType :: Monad m => ContentType -> ActionT exts m ()
contentType c = modifyHeader
(\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h)
stop :: Monad m => ActionT exts m a
stop = ActionT $ \_ s _ -> return $ Stop (toResponse s)
stopWith :: Monad m => Response -> ActionT exts m a
stopWith a = ActionT $ \_ _ _ -> return $ Stop a
redirectWith :: Monad m
=> Status
-> S.ByteString
-> ActionT exts m ()
redirectWith st url = do
status st
addHeader "location" url
redirectPermanently :: Monad m => S.ByteString -> ActionT exts m ()
redirectPermanently = redirectWith movedPermanently301
redirect :: Monad m => S.ByteString -> ActionT exts m ()
redirect to = do
v <- httpVersion <$> getRequest
if v == http11
then redirectWith seeOther303 to
else redirectWith status302 to
redirectTemporary :: Monad m => S.ByteString -> ActionT exts 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 exts m ()
rawResponse f = modifyState (\s -> s { actionResponse = ResponseFunc f } )
reset :: Monad m => ActionT exts m ()
reset = modifyState (\s -> s { actionResponse = mempty } )
file' :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts m ()
file' f p = modifyState (\s -> s { actionResponse = ResponseFile f p } )
file :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts m ()
file f p = do
mbims <- (>>= parseHTTPDate) . lookup "If-Modified-Since" <$> getHeaders
e <- liftIO $ fileExist f
t <- if e
then liftIO $ Just . epochTimeToHTTPDate . modificationTime <$> getFileStatus f
else return Nothing
case mbims of
Just ims | maybe False (ims >=) t -> reset >> status status304 >> stop
_ -> do
mime <- mimeType <$> getConfig
contentType (mime f)
maybe (return ()) (addHeader "Last-Modified" . formatHTTPDate) t
file' f p
builder :: Monad m => Builder -> ActionT exts m ()
builder b = modifyState (\s -> s { actionResponse = actionResponse s <> ResponseBuilder b } )
bytes :: Monad m => S.ByteString -> ActionT exts m ()
bytes = builder . B.fromByteString
lazyBytes :: Monad m => L.ByteString -> ActionT exts m ()
lazyBytes = builder . B.fromLazyByteString
text :: Monad m => T.Text -> ActionT exts m ()
text = builder . B.fromText
lazyText :: Monad m => TL.Text -> ActionT exts m ()
lazyText = builder . B.fromLazyText
showing :: (Monad m, Show a) => a -> ActionT exts m ()
showing = builder . B.fromShow
string :: Monad m => String -> ActionT exts m ()
string = builder . B.fromString
char :: Monad m => Char -> ActionT exts m ()
char = builder . B.fromChar
stream :: Monad m => StreamingBody -> ActionT exts m ()
stream str = modifyState (\s -> s { actionResponse = ResponseStream str })
source :: Monad m => StreamingBody -> ActionT exts m ()
source = stream
redirectFound :: Monad m => S.ByteString -> ActionT exts m ()
redirectFound = redirectWith found302
redirectSeeOther :: Monad m => S.ByteString -> ActionT exts m ()
redirectSeeOther = redirectWith seeOther303
lbs :: Monad m => L.ByteString -> ActionT exts m ()
lbs = lazyBytes