apiary 0.14.0.1 → 0.15.0

raw patch · 8 files changed

+279/−173 lines, 8 filesdep +hashabledep +unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• apiary.cabal +7/−3
• src/Control/Monad/Apiary/Action/Internal.hs +74/−81
• src/Control/Monad/Apiary/Filter.hs +8/−5
• src/Control/Monad/Apiary/Filter/Internal/Capture.hs +9/−18
• src/Control/Monad/Apiary/Internal.hs +146/−63
• src/Data/Apiary/Method.hs +14/−0
• test/main.hs +17/−3

@@ -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.

@@ -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: <https://github.com/philopon/apiary/blob/v0.15.0/bench>).+  .     * Nestable route handling(Apiary Monad; capture, method and more.).   .     * type safe route filter.   .-    * auto generate API documentation(example: <https://github.com/philopon/apiary/blob/v0.14.0/examples/api.hs>, <https://rawgit.com/philopon/apiary/v0.14.0/examples/api.html>).+    * auto generate API documentation(example: <https://github.com/philopon/apiary/blob/v0.15.0/examples/api.hs>, <https://rawgit.com/philopon/apiary/v0.15.0/examples/api.html>).   .-  more examples: <https://github.com/philopon/apiary/blob/v0.14.0/examples/>+  more examples: <https://github.com/philopon/apiary/blob/v0.15.0/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

@@ -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 

@@ -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  -------------------------------------------------------------------------------- 

@@ -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})

@@ -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

@@ -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

@@ -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