diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.15.0 +* enhance performance(new router). +* add anyPath function. + # 0.14.0 * change First Strategy behaviour(check first param only). * merge method and stdMethod function. diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 0.14.0.1 +version: 0.15.0 synopsis: Simple and type safe web framework that can be automatically generate API documentation. description: Simple and type safe web framework that can be automatically generate API documentation. @@ -31,13 +31,15 @@ 404 Page Notfound. @ . + * high performance(benchmark: ). + . * Nestable route handling(Apiary Monad; capture, method and more.). . * type safe route filter. . - * auto generate API documentation(example: , ). + * auto generate API documentation(example: , ). . - more examples: + more examples: license: MIT license-file: LICENSE @@ -110,6 +112,8 @@ , blaze-html >=0.7 && <0.8 , blaze-markup >=0.6 && <0.7 , case-insensitive >=1.1 && <1.3 + , unordered-containers >=0.2 && <0.3 + , hashable >=1.1 && <1.3 if impl(ghc < 7.8) build-depends: tagged >=0.7 && <0.8 diff --git a/src/Control/Monad/Apiary/Action/Internal.hs b/src/Control/Monad/Apiary/Action/Internal.hs --- a/src/Control/Monad/Apiary/Action/Internal.hs +++ b/src/Control/Monad/Apiary/Action/Internal.hs @@ -10,6 +10,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveFunctor #-} module Control.Monad.Apiary.Action.Internal where @@ -53,7 +54,7 @@ , failStatus :: Status , failHeaders :: ResponseHeaders -- | used by 'Control.Monad.Apiary.Filter.root' filter. - , rootPattern :: [S.ByteString] + , rootPattern :: [T.Text] , mimeType :: FilePath -> S.ByteString } @@ -77,7 +78,7 @@ , defaultHeaders = [] , failStatus = internalServerError500 , failHeaders = [] - , rootPattern = ["", "/", "/index.html", "/index.htm"] + , rootPattern = ["", "/", "index.html", "index.htm"] , mimeType = defaultMimeLookup . T.pack } @@ -88,16 +89,16 @@ , actionStatus :: Status , actionHeaders :: ResponseHeaders , actionReqBody :: Maybe ([Param], [File]) - , actionPathInfo :: [T.Text] + , actionFetches :: [T.Text] } -initialState :: ApiaryConfig -> Request -> ActionState -initialState conf req = ActionState +initialState :: ApiaryConfig -> ActionState +initialState conf = ActionState { actionResponse = responseLBS (defaultStatus conf) (defaultHeaders conf) "" , actionStatus = defaultStatus conf , actionHeaders = defaultHeaders conf , actionReqBody = Nothing - , actionPathInfo = pathInfo req + , actionFetches = [] } {-# INLINE initialState #-} @@ -110,37 +111,20 @@ } data Action a - = Continue a + = Continue ActionState a | Pass | Stop Response + deriving (Functor) -newtype ActionT m a = ActionT { unActionT :: forall b. +newtype ActionT m a = ActionT { runActionT :: ActionEnv -> ActionState - -> (a -> ActionState -> m (Action b)) - -> m (Action b) + -> m (Action a) } -runActionT :: Monad m => ActionT m a - -> ActionEnv -> ActionState - -> m (Action (a, ActionState)) -runActionT m env st = unActionT m env st $ \a st' -> - st' `seq` return (Continue (a, st')) -{-# INLINE runActionT #-} - -actionT :: Monad m - => (ActionEnv -> ActionState -> m (Action (a, ActionState))) - -> ActionT m a -actionT f = ActionT $ \env st cont -> f env st >>= \case - Pass -> return Pass - Stop s -> return $ Stop s - Continue (a,st') -> st' `seq` cont a st' -{-# INLINE actionT #-} - -- | n must be Monad, so cant be MFunctor. -hoistActionT :: (Monad m, Monad n) - => (forall b. m b -> n b) -> ActionT m a -> ActionT n a -hoistActionT run m = actionT $ \e s -> run (runActionT m e s) +hoistActionT :: (forall b. m b -> n b) -> ActionT m a -> ActionT n a +hoistActionT run m = ActionT $ \e s -> run (runActionT m e s) {-# INLINE hoistActionT #-} execActionT :: ApiaryConfig -> Documents -> ActionT IO () -> Application @@ -149,62 +133,71 @@ #else execActionT config doc m request = let send = return in #endif - runActionT m (ActionEnv config request doc) (initialState config request) >>= \case + 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 + Continue r _ -> send $ actionResponse r -------------------------------------------------------------------------------- -instance Functor (ActionT m) where - fmap f m = ActionT $ \env st cont -> - unActionT m env 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 $ \env st cont -> - unActionT mf env st $ \f st' -> - unActionT ma env st' $ \a st'' -> - st' `seq` st'' `seq` cont (f a) st'' +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 cont -> cont x st - m >>= k = ActionT $ \env st cont -> - unActionT m env st $ \a st' -> - st' `seq` unActionT (k a) env st' cont - fail s = ActionT $ \(ActionEnv{actionConfig = c}) _ _ -> return $ - Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s) + 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 cont -> - liftIO m >>= \a -> cont a st + liftIO m = ActionT $ \_ st -> + Continue st `liftM` liftIO m instance MonadTrans ActionT where - lift m = ActionT $ \_ st cont -> - m >>= \a -> cont a st + lift m = ActionT $ \_ st -> + Continue st `liftM` m instance MonadThrow m => MonadThrow (ActionT m) where - throwM e = ActionT $ \_ st cont -> - throwM e >>= \a -> cont a st + throwM e = ActionT $ \_ st -> + Continue st `liftM` throwM e instance MonadCatch m => MonadCatch (ActionT m) where - catch m h = actionT $ \env st -> + catch m h = ActionT $ \env st -> catch (runActionT m env st) (\e -> runActionT (h e) env st) {-# INLINE catch #-} instance MonadMask m => MonadMask (ActionT m) where - mask a = actionT $ \env st -> + 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 -> + 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) + q u m = ActionT $ \env st -> u (runActionT m env st) {-# INLINE mask #-} {-# INLINE uninterruptibleMask #-} @@ -215,11 +208,11 @@ {-# INLINE (<|>) #-} instance Monad m => MonadPlus (ActionT m) where - mzero = actionT $ \_ _ -> return Pass - mplus m n = actionT $ \e s -> runActionT m e s >>= \case - Continue a -> return $ Continue a - Stop stp -> return $ Stop stp - Pass -> runActionT n e s + 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 {-# INLINE mzero #-} {-# INLINE mplus #-} @@ -227,10 +220,10 @@ liftBase = liftBaseDefault instance MonadTransControl ActionT where - newtype StT ActionT a = StActionT { unStActionT :: Action (a, ActionState) } - liftWith f = actionT $ \e s -> - liftM (\a -> Continue (a,s)) (f $ \t -> liftM StActionT $ runActionT t e s) - restoreT m = actionT $ \_ _ -> liftM unStActionT m + 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 } @@ -244,7 +237,7 @@ -------------------------------------------------------------------------------- getEnv :: Monad m => ActionT m ActionEnv -getEnv = ActionT $ \e s c -> c e s +getEnv = ActionT $ \e st -> return $ Continue st e -- | get raw request. since 0.1.0.0. getRequest :: Monad m => ActionT m Request @@ -257,30 +250,30 @@ getDocuments = liftM actionDocuments getEnv getRequestBody :: MonadIO m => ActionT m ([Param], [File]) -getRequestBody = ActionT $ \e s c -> case actionReqBody s of - Just b -> c b s +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) - c b s { actionReqBody = Just b } + return $ Continue s { actionReqBody = Just b } b where convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent -- | parse request body and return params. since 0.9.0.0. getReqParams :: MonadIO m => ActionT m [Param] -getReqParams = fst <$> getRequestBody +getReqParams = fst `liftM` getRequestBody -- | parse request body and return files. since 0.9.0.0. getReqFiles :: MonadIO m => ActionT m [File] -getReqFiles = snd <$> getRequestBody +getReqFiles = snd `liftM` getRequestBody -------------------------------------------------------------------------------- modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m () -modifyState f = ActionT $ \_ s c -> c () (f s) +modifyState f = ActionT $ \_ s -> return $ Continue (f s) () -getState :: ActionT m ActionState -getState = ActionT $ \_ s c -> c s s +getState :: Monad m => ActionT m ActionState +getState = ActionT $ \_ s -> return $ Continue s s -- | set status code. since 0.1.0.0. status :: Monad m => Status -> ActionT m () @@ -314,11 +307,11 @@ -- | stop handler and send current state. since 0.3.3.0. stop :: Monad m => ActionT m a -stop = ActionT $ \_ s _ -> return $ Stop (actionResponse s) +stop = ActionT $ \_ s -> return $ Stop (actionResponse s) -- | stop with response. since 0.4.2.0. stopWith :: Monad m => Response -> ActionT m a -stopWith a = ActionT $ \_ _ _ -> return $ Stop a +stopWith a = ActionT $ \_ _ -> return $ Stop a -- | redirect handler -- @@ -354,7 +347,7 @@ -- since 0.6.2.0. redirect :: Monad m => S.ByteString -> ActionT m () redirect to = do - v <- httpVersion <$> getRequest + v <- httpVersion `liftM` getRequest if v == http11 then redirectWith seeOther303 to else redirectWith status302 to @@ -367,7 +360,7 @@ -- since 0.3.3.0. redirectTemporary :: Monad m => S.ByteString -> ActionT m () redirectTemporary to = do - v <- httpVersion <$> getRequest + v <- httpVersion `liftM` getRequest if v == http11 then redirectWith temporaryRedirect307 to else redirectWith status302 to @@ -391,7 +384,7 @@ -- | set response body file content and detect Content-Type by extension. since 0.1.0.0. file :: Monad m => FilePath -> Maybe FilePart -> ActionT m () file f p = do - mime <- mimeType <$> getConfig + mime <- mimeType `liftM` getConfig contentType (mime f) file' f p diff --git a/src/Control/Monad/Apiary/Filter.hs b/src/Control/Monad/Apiary/Filter.hs --- a/src/Control/Monad/Apiary/Filter.hs +++ b/src/Control/Monad/Apiary/Filter.hs @@ -18,6 +18,7 @@ , http09, http10, http11 -- ** path matcher , root + , anyPath , capture , Capture.path , Capture.endPath @@ -78,7 +79,7 @@ -- method \"HOGE\" -- non standard method -- @ method :: Monad n => Method -> ApiaryT c n m a -> ApiaryT c n m a -method m = function_ (DocMethod m) ((renderMethod m ==) . requestMethod) +method m = focus' (DocMethod m) (Just m) id return {-# DEPRECATED stdMethod "use method" #-} -- | filter by HTTP method using StdMethod. since 0.1.0.0. @@ -106,10 +107,12 @@ http11 = Control.Monad.Apiary.Filter.httpVersion HT.http11 "HTTP/1.1 only" -- | filter by 'Control.Monad.Apiary.Action.rootPattern' of 'Control.Monad.Apiary.Action.ApiaryConfig'. -root :: Monad n => ApiaryT c n m b -> ApiaryT c n m b -root m = do - rs <- rootPattern `liftM` apiaryConfig - function_ DocRoot (\r -> rawPathInfo r `elem` rs) m +root :: (Functor m, Monad m, Monad n) => ApiaryT c n m b -> ApiaryT c n m b +root = focus' DocRoot Nothing (RootPath:) return + +-- | match all subsequent path. since 0.15.0. +anyPath :: (Functor m, Monad m, Monad n) => ApiaryT c n m b -> ApiaryT c n m b +anyPath = focus' id Nothing (AnyPath:) return -------------------------------------------------------------------------------- diff --git a/src/Control/Monad/Apiary/Filter/Internal/Capture.hs b/src/Control/Monad/Apiary/Filter/Internal/Capture.hs --- a/src/Control/Monad/Apiary/Filter/Internal/Capture.hs +++ b/src/Control/Monad/Apiary/Filter/Internal/Capture.hs @@ -27,25 +27,16 @@ -- | check first path and drill down. since 0.11.0. path :: Monad n => T.Text -> ApiaryT c n m a -> ApiaryT c n m a -path p = focus (DocPath p) $ \l -> l <$ path' - where - path' = liftM actionPathInfo getState >>= \case - c:_ | c == p -> modifyState (\s -> s {actionPathInfo = tail $ actionPathInfo s}) - _ -> mzero +path p = focus' (DocPath p) Nothing (Exact p:) return --- | check consumed pathes. since 0.11.1. -endPath :: Monad n => ApiaryT c n m a -> ApiaryT c n m a -endPath = focus id $ \l -> l <$ end - where - end = liftM actionPathInfo getState >>= \case - [] -> return () - _ -> mzero +-- | check consumed paths. since 0.11.1. +endPath :: (Functor n, Monad n) => ApiaryT c n m a -> ApiaryT c n m a +endPath = focus' id Nothing (EndPath:) return -- | get first path and drill down. since 0.11.0. -fetch :: (Path a, Monad n) => proxy a -> Maybe Html -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b -fetch p h = focus (DocFetch (pathRep p) h) $ \l -> liftM actionPathInfo getState >>= \case - [] -> mzero - c:_ -> case readPathAs p c of +fetch :: (Path a, Functor n, Monad n) => proxy a -> Maybe Html -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b +fetch p h = focus' (DocFetch (pathRep p) h) Nothing (FetchPath:) $ \l -> liftM actionFetches getState >>= \case + [] -> mzero + f:fs -> case readPathAs p f of Nothing -> mzero - Just r -> sSnoc l r <$ - modifyState (\s -> s {actionPathInfo = tail $ actionPathInfo s}) + Just r -> sSnoc l r <$ modifyState (\s -> s {actionFetches = fs}) diff --git a/src/Control/Monad/Apiary/Internal.hs b/src/Control/Monad/Apiary/Internal.hs --- a/src/Control/Monad/Apiary/Internal.hs +++ b/src/Control/Monad/Apiary/Internal.hs @@ -5,8 +5,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} - {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} @@ -25,93 +25,160 @@ import Control.Monad.Base import Control.Monad.Apiary.Action.Internal +import Data.List import Data.Apiary.SList import Data.Apiary.Document import Data.Monoid import Text.Blaze.Html import qualified Data.Text as T +import qualified Data.ByteString as S +import Data.Apiary.Method +import qualified Data.HashMap.Strict as H +data Router n = Router + { children :: H.HashMap T.Text (Router n) + , capturing :: Maybe (Router n) + , anyMatch :: Maybe (PathMethod n) + , pathMethod :: PathMethod n + } + +data PathMethod n = PathMethod + { methodMap :: H.HashMap S.ByteString (ActionT n ()) + , anyMethod :: Maybe (ActionT n ()) + } + +emptyRouter :: Router n +emptyRouter = Router H.empty Nothing Nothing emptyPathMethod + +emptyPathMethod :: PathMethod n +emptyPathMethod = PathMethod H.empty Nothing + +insertRouter :: Monad n => [T.Text] -> Maybe S.ByteString -> [PathElem] -> ActionT n () -> Router n -> Router n +insertRouter rootPat mbMethod paths act = loop paths + where + loop [EndPath] (Router cln cap anp pm) = + Router cln cap anp $ insPathMethod pm + + loop [] (Router cln cap anp pm) = + Router cln cap (Just . insPathMethod $ maybe emptyPathMethod id anp) pm + + loop (mbp:ps) rtr@(Router cln cap anp pm) = case mbp of + FetchPath -> Router cln (Just $ loop ps (maybe emptyRouter id cap)) anp pm + Exact p -> Router (adjust' (loop ps) p cln) cap anp pm + EndPath -> loop ps rtr + AnyPath -> Router cln cap (Just . insPathMethod $ maybe emptyPathMethod id anp) pm + RootPath -> let cln' = foldl' (flip $ adjust' (loop [EndPath])) cln rootPat + in loop [EndPath] $ Router cln' cap anp pm + + adjust' f k h = H.adjust f k (H.insertWith (\_ old -> old) k emptyRouter h) + + insPathMethod (PathMethod mm am) = case mbMethod of + Nothing -> PathMethod mm (Just $ maybe act (mplus act) am) + Just m -> PathMethod (H.insertWith mplus m act mm) am + +data PathElem = Exact {-# UNPACK #-} !T.Text + | FetchPath + | RootPath + | EndPath + | AnyPath + data ApiaryEnv n c = ApiaryEnv { envFilter :: ActionT n (SList c) + , envMethod :: Maybe Method + , envPath :: [PathElem] -> [PathElem] , envConfig :: ApiaryConfig , envDoc :: Doc -> Doc } initialEnv :: Monad n => ApiaryConfig -> ApiaryEnv n '[] -initialEnv conf = ApiaryEnv (return SNil) conf id +initialEnv conf = ApiaryEnv (return SNil) Nothing id conf id data ApiaryWriter n = ApiaryWriter - { writerHandler :: ActionT n () - , writerDoc :: [Doc] + { writerRouter :: Router n -> Router n + , writerDoc :: [Doc] -> [Doc] } +instance Monoid (ApiaryWriter n) where + mempty = ApiaryWriter id id + ApiaryWriter ra da `mappend` ApiaryWriter rb db = ApiaryWriter (ra . rb) (da . db) + -- | most generic Apiary monad. since 0.8.0.0. -newtype ApiaryT c n m a = ApiaryT { unApiaryT :: forall b. +newtype ApiaryT c n m a = ApiaryT { unApiaryT :: ApiaryEnv n c - -> (a -> ApiaryWriter n -> m b) - -> m b + -> m (ApiaryWriter n, a) } -- | no transformer. (ActionT IO, ApiaryT Identity) type Apiary c = ApiaryT c IO Identity -apiaryT :: Monad m - => (ApiaryEnv n c -> m (a, ApiaryWriter n)) - -> ApiaryT c n m a -apiaryT f = ApiaryT $ \env cont -> f env >>= \(a,w) -> cont a w +routerToAction :: Monad n => Router n -> ActionT n () +routerToAction router = getRequest >>= go + where + go req = loop id router (pathInfo req) + where + method = requestMethod req + pmAction (PathMethod mm am) = + maybe mzero id (H.lookup method mm) `mplus` maybe mzero id am + + loop fch (Router _ _ anp pm) [] = do + modifyState (\s -> s { actionFetches = fch [] } ) + pmAction pm `mplus` maybe mzero pmAction anp + + loop fch (Router c mbcp anp _) (p:ps) = case mbcp of + Nothing -> cld `mplus` maybe mzero pmAction anp + Just cp -> cld `mplus` loop (fch . (p:)) cp ps `mplus` maybe mzero pmAction anp + where + cld = case H.lookup p c of + Nothing -> mzero + Just cd -> loop fch cd ps + runApiaryT :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig -> ApiaryT '[] n m a -> m Application -runApiaryT run conf m = unApiaryT m (initialEnv conf) (\_ w -> return w) >>= \wtr -> do - let doc = docsToDocuments $ writerDoc wtr - app = execActionT conf doc $ hoistActionT run (writerHandler wtr) - return app +runApiaryT run conf m = unApiaryT m (initialEnv conf) >>= \(wtr, _) -> do + let doc = docsToDocuments $ writerDoc wtr [] + rtr = writerRouter wtr emptyRouter + return $ execActionT conf doc (hoistActionT run $ routerToAction rtr) runApiary :: ApiaryConfig -> Apiary '[] a -> Application runApiary conf m = runIdentity $ runApiaryT id conf m -------------------------------------------------------------------------------- -instance Monad n => Monoid (ApiaryWriter n) where - mempty = ApiaryWriter mzero [] - ApiaryWriter ah ad `mappend` ApiaryWriter bh bd = - ApiaryWriter (mplus ah bh) (ad <> bd) - -instance Functor (ApiaryT c n m) where - fmap f m = ApiaryT $ \env cont -> - unApiaryT m env $ \a hdr -> hdr `seq` cont (f a) hdr +instance Functor m => Functor (ApiaryT c n m) where + fmap f m = ApiaryT $ \env -> + fmap f <$> unApiaryT m env -instance Monad n => Applicative (ApiaryT c n m) where - pure x = ApiaryT $ \_ cont -> cont x mempty - mf <*> ma = ApiaryT $ \env cont -> - unApiaryT mf env $ \f hdr -> - unApiaryT ma env $ \a hdr' -> - let hdr'' = hdr <> hdr' - in hdr'' `seq` cont (f a) hdr'' +instance (Functor m, Monad m, Monad n) => Applicative (ApiaryT c n m) where + pure x = ApiaryT $ \_ -> return (mempty, x) + mf <*> ma = ApiaryT $ \env -> + unApiaryT mf env >>= \(w, f) -> + unApiaryT ma env >>= \(w', a) -> + let w'' = w <> w' + in w'' `seq` return (w'', f a) -instance Monad n => Monad (ApiaryT c n m) where - return x = ApiaryT $ \_ cont -> cont x mempty - m >>= k = ApiaryT $ \env cont -> - unApiaryT m env $ \a hdr -> - unApiaryT (k a) env $ \b hdr' -> - let hdr'' = hdr <> hdr' - in hdr'' `seq` cont b hdr'' +instance (Functor m, Monad m, Monad n) => Monad (ApiaryT c n m) where + return x = ApiaryT $ \_ -> return (mempty, x) + m >>= k = ApiaryT $ \env -> + unApiaryT m env >>= \(w, a) -> + unApiaryT (k a) env >>= \(w', b) -> + let w'' = w <> w' + in w'' `seq` return (w'', b) instance Monad n => MonadTrans (ApiaryT c n) where - lift m = ApiaryT $ \_ c -> m >>= \a -> c a mempty + lift m = ApiaryT $ \_ -> (mempty,) `liftM` m -instance (Monad n, MonadIO m) => MonadIO (ApiaryT c n m) where - liftIO m = ApiaryT $ \_ c -> liftIO m >>= \a -> c a mempty +instance (Functor m, MonadIO m, Monad n) => MonadIO (ApiaryT c n m) where + liftIO m = ApiaryT $ \_ -> (mempty,) `liftM` liftIO m instance (Monad n, MonadBase b m) => MonadBase b (ApiaryT c n m) where - liftBase m = ApiaryT $ \_ c -> liftBase m >>= \a -> c a mempty + liftBase m = ApiaryT $ \_ -> (mempty,) `liftM` liftBase m instance Monad n => MonadTransControl (ApiaryT c n) where - newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter n) } - liftWith f = apiaryT $ \env -> - liftM (\a -> (a, mempty)) - (f $ \t -> liftM StTApiary' $ unApiaryT t env (\a w -> return (a,w))) - restoreT m = apiaryT $ \_ -> liftM unStTApiary' m + newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (ApiaryWriter n, a) } + liftWith f = ApiaryT $ \env -> + liftM (mempty,) (f $ \t -> liftM StTApiary' $ unApiaryT t env) + restoreT m = ApiaryT $ \_ -> liftM unStTApiary' m instance (Monad n, MonadBaseControl b m) => MonadBaseControl b (ApiaryT c n m) where newtype StM (ApiaryT c n m) a = StMApiary' { unStMApiary' :: ComposeSt (ApiaryT c n) m a } @@ -120,39 +187,55 @@ -------------------------------------------------------------------------------- -getApiaryEnv :: Monad n => ApiaryT c n m (ApiaryEnv n c) -getApiaryEnv = ApiaryT $ \env cont -> cont env mempty +getApiaryEnv :: (Monad m, Monad n) => ApiaryT c n m (ApiaryEnv n c) +getApiaryEnv = ApiaryT $ \env -> return (mempty, env) -apiaryConfig :: Monad n => ApiaryT c n m ApiaryConfig +apiaryConfig :: (Functor m, Monad m, Monad n) => ApiaryT c n m ApiaryConfig apiaryConfig = liftM envConfig getApiaryEnv -addRoute :: Monad n => ApiaryWriter n -> ApiaryT c n m () -addRoute r = ApiaryT $ \_ cont -> cont () r +addRoute :: (Monad m, Monad n) => ApiaryWriter n -> ApiaryT c n m () +addRoute r = ApiaryT $ \_ -> return (r, ()) -- | filter by action. since 0.6.1.0. -focus :: Monad n => (Doc -> Doc) -> (SList c -> ActionT n (SList c')) +focus :: Monad n + => (Doc -> Doc) + -> (SList c -> ActionT n (SList c')) -> ApiaryT c' n m a -> ApiaryT c n m a -focus d g m = ApiaryT $ \env cont -> unApiaryT m env +focus d g m = focus' d Nothing id g m + +focus' :: Monad n + => (Doc -> Doc) + -> Maybe Method + -> ([PathElem] -> [PathElem]) + -> (SList c -> ActionT n (SList c')) + -> ApiaryT c' n m a -> ApiaryT c n m a +focus' d meth pth g m = ApiaryT $ \env -> unApiaryT m env { envFilter = envFilter env >>= g - , envDoc = envDoc env . d - } cont + , envMethod = maybe (envMethod env) Just meth + , envPath = envPath env . pth + , envDoc = envDoc env . d + } -- | splice ActionT ApiaryT. -action :: Monad n => Fn c (ActionT n ()) -> ApiaryT c n m () +action :: (Functor m, Monad m, Monad n) => Fn c (ActionT n ()) -> ApiaryT c n m () action = action' . apply -- | like action. but not apply arguments. since 0.8.0.0. -action' :: Monad n => (SList c -> ActionT n ()) -> ApiaryT c n m () +action' :: (Functor m, Monad m, Monad n) => (SList c -> ActionT n ()) -> ApiaryT c n m () action' a = do env <- getApiaryEnv - addRoute $ ApiaryWriter (envFilter env >>= \c -> a c) - [envDoc env Action] - + addRoute $ ApiaryWriter + (insertRouter + (rootPattern $ envConfig env) + (renderMethod <$> envMethod env) + (envPath env []) + (envFilter env >>= \c -> a c)) + (envDoc env Action:) -------------------------------------------------------------------------------- insDoc :: (Doc -> Doc) -> ApiaryT c n m a -> ApiaryT c n m a -insDoc d m = ApiaryT $ \env cont -> unApiaryT m env - { envDoc = envDoc env . d } cont +insDoc d m = ApiaryT $ \env -> unApiaryT m env + { envDoc = envDoc env . d } -- | API document group. since 0.12.0.0. -- @@ -178,7 +261,7 @@ {-# DEPRECATED actionWithPreAction "use action'" #-} -- | execute action before main action. since 0.4.2.0 -actionWithPreAction :: Monad n => (SList xs -> ActionT n a) +actionWithPreAction :: (Functor m, Monad m, Monad n) => (SList xs -> ActionT n a) -> Fn xs (ActionT n ()) -> ApiaryT xs n m () actionWithPreAction pa a = do action' $ \c -> pa c >> apply a c diff --git a/src/Data/Apiary/Method.hs b/src/Data/Apiary/Method.hs --- a/src/Data/Apiary/Method.hs +++ b/src/Data/Apiary/Method.hs @@ -5,6 +5,7 @@ import Data.String import qualified Data.ByteString.Char8 as S +import Data.Hashable data Method = GET @@ -18,6 +19,19 @@ | PATCH | NonStandard S.ByteString deriving (Eq, Ord, Read, Show) + +instance Hashable Method where + hash GET = 0 + hash POST = 0 + hash HEAD = 0 + hash PUT = 0 + hash DELETE = 0 + hash TRACE = 0 + hash CONNECT = 0 + hash OPTIONS = 0 + hash PATCH = 0 + hash (NonStandard s) = hash s + hashWithSalt salt x = salt `hashWithSalt` hash x renderMethod :: Method -> S.ByteString renderMethod = \case diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -30,23 +30,23 @@ assertPlain200 :: L.ByteString -> Application -> Request -> IO () assertPlain200 body app req = flip runSession app $ do res <- request req + assertBody body res assertStatus 200 res assertContentType "text/plain" res - assertBody body res assertHtml200 :: L.ByteString -> Application -> Request -> IO () assertHtml200 body app req = flip runSession app $ do res <- request req + assertBody body res assertStatus 200 res assertContentType "text/html" res - assertBody body res assert404 :: Application -> Request -> IO () assert404 app req = flip runSession app $ do res <- request req + assertBody "404 Page Notfound.\n" res assertStatus 404 res assertContentType "text/plain" res - assertBody "404 Page Notfound.\n" res -------------------------------------------------------------------------------- @@ -108,7 +108,20 @@ ] -------------------------------------------------------------------------------- +anyFilterApp :: Application +anyFilterApp = runApiary def $ [capture|/test|] . anyPath . action $ do + contentType "text/plain" + lbs "hello" +anyFilterTest :: Test +anyFilterTest = testGroup "anyPath" + [ testReq "GET /" $ assert404 anyFilterApp + , testReq "GET /test" $ assertPlain200 "hello" anyFilterApp + , testReq "POST /test/foo" $ assertPlain200 "hello" anyFilterApp + ] + +-------------------------------------------------------------------------------- + captureApp :: Application captureApp = runApiary def $ do [capture|/foo|] . action $ contentType "text/plain" >> lbs "foo" @@ -252,6 +265,7 @@ , methodFilterTest , httpVersionTest , rootFilterTest + , anyFilterTest , captureTest , queryTest , multipleFilter1Test