module Control.Monad.Apiary.Action.Internal where
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote(QuasiQuoter(..))
import qualified System.PosixCompat.Files as Files
import Control.Applicative (Applicative(..), Alternative(..), (<$>))
import Control.Monad (MonadPlus(..), liftM)
import Control.Monad.Trans(MonadIO(..), MonadTrans(..))
import Control.Monad.Base(MonadBase(..), liftBaseDefault)
import Control.Monad.Reader(MonadReader(..), ReaderT)
import Control.Monad.Catch(MonadThrow(..), MonadCatch(..), MonadMask(..))
import Control.Monad.Trans.Control
(MonadTransControl(..), MonadBaseControl(..)
, ComposeSt
, defaultLiftBaseWith, defaultRestoreM)
import Network.Mime(defaultMimeLookup)
import Network.HTTP.Date(parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Parse as P
import Data.Monoid(Monoid(..), (<>))
import qualified Data.Apiary.Dict as Dict
import Data.Apiary.Param(Param, File(..))
import Data.Apiary.Compat(SProxy(..))
import Data.Apiary.Document(Documents)
import Data.Apiary.Document.Html(defaultDocumentToHtml, DefaultDocumentConfig)
import Data.Default.Class(Default(..))
import Blaze.ByteString.Builder(Builder)
import Text.Blaze.Html.Renderer.Utf8(renderHtmlBuilder)
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
import qualified Data.Vault.Lazy as V
data ApiaryConfig = ApiaryConfig
{
notFound :: Wai.Application
, defaultStatus :: HTTP.Status
, defaultHeaders :: HTTP.ResponseHeaders
, defaultContentType :: S.ByteString
, failStatus :: HTTP.Status
, failHeaders :: HTTP.ResponseHeaders
, rootPattern :: [T.Text]
, mimeType :: FilePath -> S.ByteString
}
defaultDocumentationAction :: Monad m => DefaultDocumentConfig -> ActionT exts prms m ()
defaultDocumentationAction conf = do
d <- getDocuments
contentType "text/html"
builder . renderHtmlBuilder $ defaultDocumentToHtml conf d
defaultNotFound :: Wai.Application
defaultNotFound _ f = f $ Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"
instance Default ApiaryConfig where
def = ApiaryConfig
{ notFound = defaultNotFound
, defaultStatus = HTTP.ok200
, defaultHeaders = []
, defaultContentType = "text/plain"
, failStatus = HTTP.internalServerError500
, failHeaders = []
, rootPattern = ["index.html", "index.htm"]
, mimeType = defaultMimeLookup . T.pack
}
data ResponseBody
= ResponseFile FilePath (Maybe Wai.FilePart)
| ResponseBuilder Builder
| ResponseStream Wai.StreamingBody
| ResponseRaw (IO S.ByteString -> (S.ByteString -> IO ()) -> IO ()) Wai.Response
| ResponseFunc (HTTP.Status -> HTTP.ResponseHeaders -> Wai.Response)
instance Monoid ResponseBody where
mempty = ResponseBuilder mempty
ResponseBuilder a `mappend` ResponseBuilder b = ResponseBuilder $ a <> b
_ `mappend` b = b
toResponse :: ActionState -> Wai.Response
toResponse ActionState{..} = case actionResponse of
ResponseFile f p -> Wai.responseFile actionStatus headers f p
ResponseBuilder b -> Wai.responseBuilder actionStatus headers b
ResponseStream s -> Wai.responseStream actionStatus headers s
ResponseRaw f r -> Wai.responseRaw f r
ResponseFunc f -> f actionStatus headers
where
headers = ("Content-Type", actionContentType) : actionHeaders
data ActionState = ActionState
{ actionResponse :: ResponseBody
, actionStatus :: HTTP.Status
, actionHeaders :: HTTP.ResponseHeaders
, actionVault :: V.Vault
, actionContentType :: S.ByteString
, actionReqBody :: Maybe ([Param], [File])
, actionFetches :: [T.Text]
}
initialState :: ApiaryConfig -> ActionState
initialState conf = ActionState
{ actionResponse = ResponseBuilder mempty
, actionStatus = defaultStatus conf
, actionHeaders = defaultHeaders conf
, actionVault = V.empty
, actionContentType = defaultContentType conf
, actionReqBody = Nothing
, actionFetches = []
}
data Extensions (es :: [*]) where
NoExtension :: Extensions '[]
AddExtension :: Extension e => (e :: *) -> Extensions es -> Extensions (e ': es)
type Middleware' = forall exts. ActionT exts '[] IO () -> ActionT exts '[] IO ()
class Extension e where
extMiddleware :: e -> Wai.Middleware
extMiddleware _ = id
extMiddleware' :: e -> Middleware'
extMiddleware' _ = id
class Monad m => MonadExts es m | m -> es where
getExts :: m (Extensions es)
instance Monad m => MonadExts es (ReaderT (Extensions es) m) where
getExts = ask
data ActionEnv exts = ActionEnv
{ actionConfig :: ApiaryConfig
, actionRequest :: Wai.Request
, actionDocuments :: Documents
, actionExts :: Extensions exts
}
data Action a
= Continue ActionState a
| Pass
| Stop Wai.Response
newtype ActionT exts prms m a = ActionT { unActionT :: forall b.
Dict.Dict prms
-> ActionEnv exts
-> ActionState
-> (a -> ActionState -> m (Action b))
-> m (Action b)
} deriving (Functor)
runActionT :: Monad m => ActionT exts prms m a
-> Dict.Dict prms -> ActionEnv exts -> ActionState
-> m (Action a)
runActionT m dict env st = unActionT m dict env st $ \a !st' ->
return (Continue st' a)
actionT :: Monad m
=> (Dict.Dict prms -> ActionEnv exts -> ActionState -> m (Action a))
-> ActionT exts prms m a
actionT f = ActionT $ \dict env !st cont -> f dict 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 prms m a -> ActionT exts prms n a
hoistActionT run m = actionT $ \d e s -> run (runActionT m d e s)
applyDict :: Dict.Dict prms -> ActionT exts prms m a -> ActionT exts '[] m a
applyDict d (ActionT m) = ActionT $ const (m d)
execActionT :: ApiaryConfig -> Extensions exts -> Documents -> ActionT exts '[] IO () -> Wai.Application
execActionT config exts doc m request send =
runActionT m Dict.empty (ActionEnv config request doc exts) (initialState config) >>= \case
Pass -> notFound config request send
Stop s -> send s
Continue r _ -> send $ toResponse r
instance Applicative (ActionT exts prms m) where
pure x = ActionT $ \_ _ !st cont -> cont x st
mf <*> ma = ActionT $ \dict env st cont ->
unActionT mf dict env st $ \f !st' ->
unActionT ma dict env st' $ \a !st'' ->
cont (f a) st''
instance Monad m => Monad (ActionT exts prms m) where
return x = ActionT $ \_ _ !st cont -> cont x st
m >>= k = ActionT $ \dict env !st cont ->
unActionT m dict env st $ \a !st' ->
unActionT (k a) dict env st' cont
fail s = ActionT $ \_ (ActionEnv{actionConfig = c}) _ _ -> return $
Stop (Wai.responseLBS (failStatus c) (failHeaders c) $ LC.pack s)
instance MonadIO m => MonadIO (ActionT exts prms m) where
liftIO m = ActionT $ \_ _ !st cont ->
liftIO m >>= \a -> cont a st
instance MonadTrans (ActionT exts prms) where
lift m = ActionT $ \_ _ !st cont ->
m >>= \a -> cont a st
instance MonadThrow m => MonadThrow (ActionT exts prms m) where
throwM e = ActionT $ \_ _ !st cont ->
throwM e >>= \a -> cont a st
instance MonadCatch m => MonadCatch (ActionT exts prms m) where
catch m h = ActionT $ \dict env !st cont ->
catch (unActionT m dict env st cont) (\e -> unActionT (h e) dict env st cont)
instance MonadMask m => MonadMask (ActionT exts prms m) where
mask a = ActionT $ \dict env !st cont ->
mask $ \u -> unActionT (a $ q u) dict env st cont
where
q u m = actionT $ \dict env !st -> u (runActionT m dict env st)
uninterruptibleMask a = ActionT $ \dict env !st cont ->
uninterruptibleMask $ \u -> unActionT (a $ q u) dict env st cont
where
q u m = actionT $ \dict env !st -> u (runActionT m dict env st)
instance (Monad m, Functor m) => Alternative (ActionT exts prms m) where
empty = mzero
(<|>) = mplus
instance Monad m => MonadPlus (ActionT exts prms m) where
mzero = ActionT $ \_ _ _ _ -> return Pass
mplus m n = ActionT $ \dict e !s cont -> unActionT m dict e s cont >>= \case
Continue !st a -> return $ Continue st a
Stop stp -> return $ Stop stp
Pass -> unActionT n dict e s cont
instance MonadBase b m => MonadBase b (ActionT exts prms m) where
liftBase = liftBaseDefault
instance MonadTransControl (ActionT exts prms) where
newtype StT (ActionT exts prms) a = StActionT { unStActionT :: Action a }
liftWith f = actionT $ \prms e !s ->
liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t prms e s)
restoreT m = actionT $ \_ _ _ -> liftM unStActionT m
instance MonadBaseControl b m => MonadBaseControl b (ActionT exts prms m) where
newtype StM (ActionT exts prms m) a = StMActionT { unStMActionT :: ComposeSt (ActionT exts prms) m a }
liftBaseWith = defaultLiftBaseWith StMActionT
restoreM = defaultRestoreM unStMActionT
instance MonadReader r m => MonadReader r (ActionT exts prms m) where
ask = lift ask
local f = hoistActionT $ local f
instance Monad m => MonadExts exts (ActionT exts prms m) where
getExts = liftM actionExts getEnv
getEnv :: Monad m => ActionT exts prms m (ActionEnv exts)
getEnv = ActionT $ \_ e s c -> c e s
getRequest :: Monad m => ActionT exts prms m Wai.Request
getRequest = liftM actionRequest getEnv
getConfig :: Monad m => ActionT exts prms m ApiaryConfig
getConfig = liftM actionConfig getEnv
getParams :: Monad m => ActionT exts prms m (Dict.Dict prms)
getParams = ActionT $ \d _ s c -> c d s
param :: (Dict.Member k v prms, Monad m) => proxy k -> ActionT exts prms m v
param p = liftM (Dict.get p) getParams
paramsE :: [String] -> TH.ExpQ
paramsE ps = do
ns <- mapM (\p -> (,) <$> TH.newName "x" <*> pure p) ps
let bs = map (\(v, k) -> TH.bindS (TH.varP v) (prm k)) ns
tpl = TH.noBindS [| return $(TH.tupE $ map (TH.varE . fst) ns) |]
TH.doE $ bs ++ [tpl]
where
prm n = [| param (SProxy :: SProxy $(TH.litT $ TH.strTyLit n)) |]
params :: QuasiQuoter
params = QuasiQuoter
{ quoteExp = paramsE . map (T.unpack . T.strip) . T.splitOn "," . T.pack
, quotePat = error "params QQ is defined only exp."
, quoteType = error "params QQ is defined only exp."
, quoteDec = error "params QQ is defined only exp."
}
getDocuments :: Monad m => ActionT exts prms m Documents
getDocuments = liftM actionDocuments getEnv
getRequestBody :: MonadIO m => ActionT exts prms 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
getQueryParams :: Monad m => ActionT exts prms m HTTP.Query
getQueryParams = Wai.queryString <$> getRequest
getReqBodyParams :: MonadIO m => ActionT exts prms m [Param]
getReqBodyParams = fst <$> getRequestBody
getReqBodyFiles :: MonadIO m => ActionT exts prms m [File]
getReqBodyFiles = snd <$> getRequestBody
getHeaders :: Monad m => ActionT exts prms m HTTP.RequestHeaders
getHeaders = Wai.requestHeaders `liftM` getRequest
modifyState :: Monad m => (ActionState -> ActionState) -> ActionT exts prms m ()
modifyState f = ActionT $ \_ _ s c -> c () (f s)
status :: Monad m => HTTP.Status -> ActionT exts prms m ()
status st = modifyState (\s -> s { actionStatus = st } )
modifyHeader :: Monad m => (HTTP.ResponseHeaders -> HTTP.ResponseHeaders) -> ActionT exts prms m ()
modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } )
addHeader :: Monad m => HTTP.HeaderName -> S.ByteString -> ActionT exts prms m ()
addHeader h v = modifyHeader ((h,v):)
setHeaders :: Monad m => HTTP.ResponseHeaders -> ActionT exts prms m ()
setHeaders hs = modifyHeader (const hs)
type ContentType = S.ByteString
contentType :: Monad m => ContentType -> ActionT exts prms m ()
contentType c = modifyState (\s -> s { actionContentType = c } )
getState :: ActionT exts prms m ActionState
getState = ActionT $ \_ _ s c -> c s s
lookupVault :: V.Key a -> ActionT exts prms m (Maybe a)
lookupVault k = V.lookup k . actionVault <$> getState
modifyVault :: (V.Vault -> V.Vault) -> ActionT exts prms m ()
modifyVault f = ActionT $ \_ _ s c -> c () (s {actionVault = f $ actionVault s})
insertVault :: V.Key a -> a -> ActionT exts prms m ()
insertVault k i = modifyVault $ V.insert k i
adjustVault :: (a -> a) -> V.Key a -> ActionT exts prms m ()
adjustVault f k = modifyVault $ V.adjust f k
deleteVault :: V.Key a -> ActionT exts prms m ()
deleteVault k = modifyVault $ V.delete k
stop :: Monad m => ActionT exts prms m a
stop = ActionT $ \_ _ s _ -> return $ Stop (toResponse s)
stopWith :: Monad m => Wai.Response -> ActionT exts prms m a
stopWith a = ActionT $ \_ _ _ _ -> return $ Stop a
redirectWith :: Monad m
=> HTTP.Status
-> S.ByteString
-> ActionT exts prms m ()
redirectWith st url = do
status st
addHeader "location" url
redirectPermanently :: Monad m => S.ByteString -> ActionT exts prms m ()
redirectPermanently = redirectWith HTTP.movedPermanently301
redirect :: Monad m => S.ByteString -> ActionT exts prms m ()
redirect to = do
v <- Wai.httpVersion <$> getRequest
if v == HTTP.http11
then redirectWith HTTP.seeOther303 to
else redirectWith HTTP.status302 to
redirectTemporary :: Monad m => S.ByteString -> ActionT exts prms m ()
redirectTemporary to = do
v <- Wai.httpVersion <$> getRequest
if v == HTTP.http11
then redirectWith HTTP.temporaryRedirect307 to
else redirectWith HTTP.status302 to
rawResponse :: Monad m => (HTTP.Status -> HTTP.ResponseHeaders -> Wai.Response) -> ActionT exts prms m ()
rawResponse f = modifyState (\s -> s { actionResponse = ResponseFunc f } )
reset :: Monad m => ActionT exts prms m ()
reset = modifyState (\s -> s { actionResponse = mempty } )
file' :: MonadIO m => FilePath -> Maybe Wai.FilePart -> ActionT exts prms m ()
file' f p = modifyState (\s -> s { actionResponse = ResponseFile f p } )
file :: MonadIO m => FilePath -> Maybe Wai.FilePart -> ActionT exts prms m ()
file f p = do
mbims <- (>>= parseHTTPDate) . lookup "If-Modified-Since" <$> getHeaders
e <- liftIO $ Files.fileExist f
t <- if e
then liftIO $ Just . epochTimeToHTTPDate . Files.modificationTime <$> Files.getFileStatus f
else return Nothing
case mbims of
Just ims | maybe False (ims >=) t -> reset >> status HTTP.status304 >> stop
_ -> do
mime <- mimeType <$> getConfig
contentType (mime f)
maybe (return ()) (addHeader "Last-Modified" . formatHTTPDate) t
file' f p
devFile' :: MonadIO m => FilePath -> ActionT exts prms m ()
devFile' f = liftIO (Files.fileExist f) >>= \e ->
if e
then liftIO (L.readFile f) >>= lazyBytes
else mzero
devFile :: MonadIO m => FilePath -> ActionT exts prms m ()
devFile f = do
mime <- mimeType <$> getConfig
contentType (mime f)
devFile' f
builder :: Monad m => Builder -> ActionT exts prms m ()
builder b = modifyState (\s -> s { actionResponse = ResponseBuilder b } )
bytes :: Monad m => S.ByteString -> ActionT exts prms m ()
bytes = builder . B.fromByteString
lazyBytes :: Monad m => L.ByteString -> ActionT exts prms m ()
lazyBytes = builder . B.fromLazyByteString
text :: Monad m => T.Text -> ActionT exts prms m ()
text = builder . B.fromText
lazyText :: Monad m => TL.Text -> ActionT exts prms m ()
lazyText = builder . B.fromLazyText
showing :: (Monad m, Show a) => a -> ActionT exts prms m ()
showing = builder . B.fromShow
string :: Monad m => String -> ActionT exts prms m ()
string = builder . B.fromString
char :: Monad m => Char -> ActionT exts prms m ()
char = builder . B.fromChar
appendBuilder :: Monad m => Builder -> ActionT exts prms m ()
appendBuilder b = modifyState (\s -> s { actionResponse = actionResponse s <> ResponseBuilder b } )
appendBytes :: Monad m => S.ByteString -> ActionT exts prms m ()
appendBytes = appendBuilder . B.fromByteString
appendLazyBytes :: Monad m => L.ByteString -> ActionT exts prms m ()
appendLazyBytes = appendBuilder . B.fromLazyByteString
appendText :: Monad m => T.Text -> ActionT exts prms m ()
appendText = appendBuilder . B.fromText
appendLazyText :: Monad m => TL.Text -> ActionT exts prms m ()
appendLazyText = appendBuilder . B.fromLazyText
appendShowing :: (Monad m, Show a) => a -> ActionT exts prms m ()
appendShowing = appendBuilder . B.fromShow
appendString :: Monad m => String -> ActionT exts prms m ()
appendString = appendBuilder . B.fromString
appendChar :: Monad m => Char -> ActionT exts prms m ()
appendChar = appendBuilder . B.fromChar
stream :: Monad m => Wai.StreamingBody -> ActionT exts prms m ()
stream str = modifyState (\s -> s { actionResponse = ResponseStream str })