diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +# 0.14.0 +* change First Strategy behaviour(check first param only). +* merge method and stdMethod function. +* rename function (response -> rawResponse) +* add apiary-purescript + +## documentation +* changed how to generate documentation. use defaultDocumentationAction action. +* now, condition which is after document function, will be documented. use noDoc function. +* abolish ':' query document api. use (??) function. +* deprecated () route decument api. use []. + # 0.13.0 * Option that generate full embed documentation. * Add precondition, rpHtml functions. diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 0.13.0 +version: 0.14.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. @@ -14,7 +14,7 @@ . main :: IO () main = run 3000 . runApiary def $ do - [capture|/:Int|] . ("name" =: pLazyByteString) . stdMethod GET . action $ \\age name -> do + [capture|/:Int|] . ("name" =: pLazyByteString) . method GET . action $ \\age name -> do guard (age >= 18) contentType "text/html" lbs . L.concat $ ["<h1>Hello, ", name, "!</h1>\\n"] @@ -31,13 +31,13 @@ 404 Page Notfound. @ . - * Nestable route handling(Apiary Monad; capture, stdMethod and more.). + * 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 @@ -74,7 +74,10 @@ Data.Apiary.SList Data.Apiary.Param + Data.Apiary.Method + Data.Apiary.Proxy Data.Apiary.Document + Data.Apiary.Document.Html other-modules: Control.Monad.Apiary.Internal Control.Monad.Apiary.Action.Internal diff --git a/src/Control/Monad/Apiary.hs b/src/Control/Monad/Apiary.hs --- a/src/Control/Monad/Apiary.hs +++ b/src/Control/Monad/Apiary.hs @@ -2,7 +2,6 @@ ( ApiaryT, Apiary , runApiary , runApiaryT - , runApiaryT' -- * getter , apiaryConfig -- * execute action @@ -11,10 +10,12 @@ , group , document , precondition + , noDoc , rpHtml -- * deprecated , actionWithPreAction ) where import Control.Monad.Apiary.Internal -import Data.Apiary.Document (rpHtml) + +import Data.Apiary.Document.Html (rpHtml) diff --git a/src/Control/Monad/Apiary/Action.hs b/src/Control/Monad/Apiary/Action.hs --- a/src/Control/Monad/Apiary/Action.hs +++ b/src/Control/Monad/Apiary/Action.hs @@ -12,6 +12,7 @@ , getRequest , getHeaders , getReqParams + , File(..) , getReqFiles -- ** setter @@ -21,13 +22,12 @@ , ContentType , contentType -- *** response body - , File(..) , file , file' , builder , lbs , stream - , response + , rawResponse , StreamingBody @@ -35,19 +35,15 @@ -- *** redirect , redirect, redirectPermanently, redirectTemporary , redirectWith - -- * Reexport - , module Data.Default.Class - , module Network.HTTP.Types.Status - + -- * deprecated , redirectFound, redirectSeeOther, source ) where import Control.Monad.Apiary.Action.Internal -import Data.Default.Class + import Data.Apiary.Param -import Data.Apiary.Document -import Network.HTTP.Types.Status hiding (mkStatus) +import Data.Apiary.Document.Html #ifdef WAI3 import Network.Wai 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 @@ -21,14 +21,16 @@ import Control.Monad.Catch import Control.Monad.Trans.Control -import Network.Wai -import qualified Network.Wai.Parse as P 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 @@ -38,6 +40,7 @@ #ifndef WAI3 import Data.Conduit +type StreamingBody = Source IO (Flush Builder) #endif data ApiaryConfig = ApiaryConfig @@ -52,38 +55,33 @@ -- | used by 'Control.Monad.Apiary.Filter.root' filter. , rootPattern :: [S.ByteString] , mimeType :: FilePath -> S.ByteString - , documentationAction :: Maybe (Documents -> ActionT IO ()) } -defaultDocumentationAction :: Monad m => S.ByteString -> DefaultDocumentConfig -> Documents -> ActionT m () -defaultDocumentationAction r conf d = do - p <- rawPathInfo <$> getRequest - guard $ p == r +defaultDocumentationAction :: Monad m => DefaultDocumentConfig -> ActionT m () +defaultDocumentationAction conf = do + d <- getDocuments contentType "text/html" builder . renderHtmlBuilder $ defaultDocumentToHtml conf d -defNotFound :: Application +defaultNotFound :: Application #ifdef WAI3 -defNotFound _ f = f $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n" +defaultNotFound _ f = f $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n" #else -defNotFound _ = return $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n" +defaultNotFound _ = return $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n" #endif instance Default ApiaryConfig where def = ApiaryConfig - { notFound = defNotFound + { notFound = defaultNotFound , defaultStatus = ok200 , defaultHeaders = [] , failStatus = internalServerError500 , failHeaders = [] , rootPattern = ["", "/", "/index.html", "/index.htm"] , mimeType = defaultMimeLookup . T.pack - , documentationAction = Just $ defaultDocumentationAction - "/api/documentation" def } -convFile :: (S.ByteString, P.FileInfo L.ByteString) -> File -convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent +-------------------------------------------------------------------------------- data ActionState = ActionState { actionResponse :: Response @@ -101,80 +99,39 @@ , actionReqBody = Nothing , actionPathInfo = pathInfo req } +{-# INLINE initialState #-} -#ifndef WAI3 -type StreamingBody = Source IO (Flush Builder) -#endif +-------------------------------------------------------------------------------- +data ActionEnv = ActionEnv + { actionConfig :: ApiaryConfig + , actionRequest :: Request + , actionDocuments :: Documents + } + data Action a = Continue a | Pass | Stop Response newtype ActionT m a = ActionT { unActionT :: forall b. - ApiaryConfig - -> Request + ActionEnv -> ActionState -> (a -> ActionState -> m (Action b)) -> m (Action b) } -instance Functor (ActionT m) where - fmap f m = ActionT $ \conf req st cont -> - unActionT m conf req 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 $ \conf req st cont -> - unActionT mf conf req st $ \f st' -> - unActionT ma conf req st' $ \a st'' -> - st' `seq` st'' `seq` cont (f a) st'' - -instance Monad m => Monad (ActionT m) where - return x = ActionT $ \_ _ st cont -> cont x st - m >>= k = ActionT $ \conf req st cont -> - unActionT m conf req st $ \a st' -> - st' `seq` unActionT (k a) conf req st' cont - fail s = ActionT $ \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 - -instance MonadTrans ActionT where - lift m = ActionT $ \_ _ st cont -> - m >>= \a -> cont a st - -instance MonadThrow m => MonadThrow (ActionT m) where - throwM e = ActionT $ \_ _ st cont -> - throwM e >>= \a -> cont a st - -instance MonadCatch m => MonadCatch (ActionT m) where - catch m h = actionT $ \conf req st -> - catch (runActionT m conf req st) (\e -> runActionT (h e) conf req st) - -instance MonadMask m => MonadMask (ActionT m) where - mask a = actionT $ \conf req st -> - mask $ \u -> runActionT (a $ q u) conf req st - where - q u m = actionT $ \conf req st -> u (runActionT m conf req st) - uninterruptibleMask a = actionT $ \conf req st -> - uninterruptibleMask $ \u -> runActionT (a $ q u) conf req st - where - q u m = actionT $ \conf req st -> u (runActionT m conf req st) - runActionT :: Monad m => ActionT m a - -> ApiaryConfig -> Request -> ActionState + -> ActionEnv -> ActionState -> m (Action (a, ActionState)) -runActionT m conf req st = unActionT m conf req st $ \a st' -> +runActionT m env st = unActionT m env st $ \a st' -> st' `seq` return (Continue (a, st')) {-# INLINE runActionT #-} actionT :: Monad m - => (ApiaryConfig -> Request -> ActionState -> m (Action (a, ActionState))) + => (ActionEnv -> ActionState -> m (Action (a, ActionState))) -> ActionT m a -actionT f = ActionT $ \conf req st cont -> f conf req st >>= \case +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' @@ -183,16 +140,16 @@ -- | 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 $ \c r s -> run (runActionT m c r s) - -execActionT :: ApiaryConfig -> ActionT IO () -> Application +hoistActionT run m = actionT $ \e s -> run (runActionT m e s) +{-# INLINE hoistActionT #-} +execActionT :: ApiaryConfig -> Documents -> ActionT IO () -> Application #ifdef WAI3 -execActionT config m request send = +execActionT config doc m request send = #else -execActionT config m request = let send = return in +execActionT config doc m request = let send = return in #endif - runActionT m config request (initialState config request) >>= \case + runActionT m (ActionEnv config request doc) (initialState config request) >>= \case #ifdef WAI3 Pass -> notFound config request send #else @@ -201,25 +158,79 @@ Stop s -> send s 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 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) + +instance MonadIO m => MonadIO (ActionT m) where + liftIO m = ActionT $ \_ st cont -> + liftIO m >>= \a -> cont a st + +instance MonadTrans ActionT where + lift m = ActionT $ \_ st cont -> + m >>= \a -> cont a st + +instance MonadThrow m => MonadThrow (ActionT m) where + throwM e = ActionT $ \_ st cont -> + throwM e >>= \a -> cont a st + +instance MonadCatch m => MonadCatch (ActionT m) where + 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 $ \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) + {-# INLINE mask #-} + {-# INLINE uninterruptibleMask #-} + instance (Monad m, Functor m) => Alternative (ActionT m) where empty = mzero (<|>) = mplus + {-# INLINE empty #-} + {-# INLINE (<|>) #-} instance Monad m => MonadPlus (ActionT m) where - mzero = actionT $ \_ _ _ -> return Pass - mplus m n = actionT $ \c r s -> runActionT m c r s >>= \case + 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 c r s + Pass -> runActionT n e s + {-# INLINE mzero #-} + {-# INLINE mplus #-} instance MonadBase b m => MonadBase b (ActionT m) where liftBase = liftBaseDefault instance MonadTransControl ActionT where newtype StT ActionT a = StActionT { unStActionT :: Action (a, ActionState) } - liftWith f = actionT $ \c r s -> - liftM (\a -> Continue (a,s)) (f $ \t -> liftM StActionT $ runActionT t c r s) - restoreT m = actionT $ \_ _ _ -> liftM unStActionT m + liftWith f = actionT $ \e s -> + liftM (\a -> Continue (a,s)) (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 } @@ -230,25 +241,30 @@ ask = lift ask local f = hoistActionT $ local f --- | 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 with response. since 0.4.2.0. -stopWith :: Monad m => Response -> ActionT m a -stopWith a = ActionT $ \_ _ _ _ -> return $ Stop a +getEnv :: Monad m => ActionT m ActionEnv +getEnv = ActionT $ \e s c -> c e s -- | get raw request. since 0.1.0.0. getRequest :: Monad m => ActionT m Request -getRequest = ActionT $ \_ r s c -> c r s +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 $ \_ r s c -> case actionReqBody s of +getRequestBody = ActionT $ \e s c -> case actionReqBody s of Just b -> c b s Nothing -> do - (p,f) <- liftIO $ P.parseRequestBody P.lbsBackEnd r + (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 -- | parse request body and return params. since 0.9.0.0. getReqParams :: MonadIO m => ActionT m [Param] @@ -258,23 +274,22 @@ getReqFiles :: MonadIO m => ActionT m [File] getReqFiles = snd <$> getRequestBody -getConfig :: Monad m => ActionT m ApiaryConfig -getConfig = ActionT $ \c _ s cont -> cont c s +-------------------------------------------------------------------------------- modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m () -modifyState f = ActionT $ \_ _ s c -> c () (f s) +modifyState f = ActionT $ \_ s c -> c () (f s) getState :: ActionT m ActionState -getState = ActionT $ \_ _ s c -> c s s - --- | get all request headers. since 0.6.0.0. -getHeaders :: Monad m => ActionT m RequestHeaders -getHeaders = requestHeaders `liftM` getRequest +getState = ActionT $ \_ s c -> c s s -- | set status code. since 0.1.0.0. status :: Monad m => Status -> ActionT m () status st = modifyState (\s -> s { actionStatus = st } ) +-- | get all request headers. since 0.6.0.0. +getHeaders :: Monad m => ActionT m RequestHeaders +getHeaders = requestHeaders `liftM` getRequest + -- | modify response header. since 0.1.0.0. modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT m () modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } ) @@ -295,6 +310,16 @@ contentType c = modifyHeader (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h) +-------------------------------------------------------------------------------- + +-- | 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 with response. since 0.4.2.0. +stopWith :: Monad m => Response -> ActionT m a +stopWith a = ActionT $ \_ _ _ -> return $ Stop a + -- | redirect handler -- -- set status and add location header. since 0.3.3.0. @@ -347,13 +372,6 @@ then redirectWith temporaryRedirect307 to else redirectWith status302 to --- | 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 - contentType (mime f) - file' f p - -- | Raw response constructor. since 0.10. -- -- example(use pipes-wai) @@ -363,27 +381,34 @@ -- producer = response (\s h -> responseProducer s h) -- @ -- -response :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT m () -response f = modifyState (\s -> s { actionResponse = f (actionStatus s) (actionHeaders s)} ) +rawResponse :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT m () +rawResponse f = modifyState (\s -> s { actionResponse = f (actionStatus s) (actionHeaders s)} ) -- | set response body file content, without set Content-Type. since 0.1.0.0. file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m () -file' f p = response (\s h -> responseFile s h f p) +file' f p = rawResponse (\s h -> responseFile s h f p) +-- | 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 + contentType (mime f) + file' f p + -- | set response body builder. since 0.1.0.0. builder :: Monad m => Builder -> ActionT m () -builder b = response (\s h -> responseBuilder s h b) +builder b = rawResponse (\s h -> responseBuilder s h b) -- | set response body lazy bytestring. since 0.1.0.0. lbs :: Monad m => L.ByteString -> ActionT m () -lbs l = response (\s h -> responseLBS s h l) +lbs l = rawResponse (\s h -> responseLBS s h l) -- | set response body source. since 0.9.0.0. stream :: Monad m => StreamingBody -> ActionT m () #ifdef WAI3 -stream str = response (\s h -> responseStream s h str) +stream str = rawResponse (\s h -> responseStream s h str) #else -stream str = response (\s h -> responseSource s h str) +stream str = rawResponse (\s h -> responseSource s h str) #endif {-# DEPRECATED source "use stream" #-} 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 @@ -7,11 +7,12 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Control.Monad.Apiary.Filter ( -- * filters -- ** http method - method, stdMethod + method, Method(..) -- ** http version , Control.Monad.Apiary.Filter.httpVersion , http09, http10, http11 @@ -39,46 +40,50 @@ -- ** other , ssl - -- * Reexport - -- | StdMethod(..) - , module Network.HTTP.Types - -- | Strategy Proxies - , module Control.Monad.Apiary.Filter.Internal.Strategy + -- * deprecated + , stdMethod ) where -import Control.Monad -import Control.Monad.Trans import Network.Wai as Wai import qualified Network.HTTP.Types as HT -import Network.HTTP.Types (StdMethod(..)) + +import Control.Monad +import Control.Monad.Trans + +import Control.Monad.Apiary.Action.Internal +import Control.Monad.Apiary.Filter.Internal +import Control.Monad.Apiary.Filter.Internal.Capture.TH +import Control.Monad.Apiary.Internal +import qualified Control.Monad.Apiary.Filter.Internal.Strategy as Strategy +import qualified Control.Monad.Apiary.Filter.Internal.Capture as Capture + +import Text.Blaze.Html import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as SC import Data.Monoid import Data.Proxy import Data.String import Data.Reflection -import Text.Blaze.Html import Data.Apiary.SList import Data.Apiary.Param import Data.Apiary.Document - -import Control.Monad.Apiary.Action.Internal -import Control.Monad.Apiary.Filter.Internal -import qualified Control.Monad.Apiary.Filter.Internal.Strategy as Strategy -import Control.Monad.Apiary.Filter.Internal.Strategy (pFirst, pOne, pOption, pCheck, pMany, pSome) -import qualified Control.Monad.Apiary.Filter.Internal.Capture as Capture -import Control.Monad.Apiary.Filter.Internal.Capture.TH -import Control.Monad.Apiary.Internal +import Data.Apiary.Method -- | filter by HTTP method. since 0.1.0.0. -method :: Monad n => HT.Method -> ApiaryT c n m a -> ApiaryT c n m a -method m = function_ (DocMethod m) ((m ==) . requestMethod) +-- +-- @ +-- method GET -- stdmethod +-- 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) +{-# DEPRECATED stdMethod "use method" #-} -- | filter by HTTP method using StdMethod. since 0.1.0.0. -stdMethod :: Monad n => StdMethod -> ApiaryT c n m a -> ApiaryT c n m a -stdMethod = method . HT.renderStdMethod +stdMethod :: Monad n => Method -> ApiaryT c n m a -> ApiaryT c n m a +stdMethod = method -- | filter by ssl accessed. since 0.1.0.0. ssl :: Monad n => ApiaryT c n m a -> ApiaryT c n m a @@ -106,15 +111,15 @@ rs <- rootPattern `liftM` apiaryConfig function_ DocRoot (\r -> rawPathInfo r `elem` rs) m +-------------------------------------------------------------------------------- + data QueryKey = QueryKey { queryKey :: S.ByteString , queryDesc :: Maybe Html } instance IsString QueryKey where - fromString s = case break (== ':') s of - (k, []) -> QueryKey (SC.pack k) Nothing - (k, d) -> QueryKey (SC.pack k) (Just . toHtml $ tail d) + fromString s = QueryKey (SC.pack s) Nothing (??) :: QueryKey -> Html -> QueryKey QueryKey k _ ?? d = QueryKey k (Just d) @@ -147,9 +152,7 @@ Strategy.readStrategy id ((queryKey ==) . fst) p (reqParams (Proxy :: Proxy a) r q f) l where - doc = case queryDesc of - Nothing -> id - Just h -> DocQuery queryKey (Strategy.strategyRep (Proxy :: Proxy w)) (reqParamRep (Proxy :: Proxy a)) h + doc = DocQuery queryKey (Strategy.strategyRep (Proxy :: Proxy w)) (reqParamRep (Proxy :: Proxy a)) queryDesc -- | get first matched paramerer. since 0.5.0.0. -- @@ -158,7 +161,7 @@ -- @ (=:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b -k =: t = query k (pFirst t) +k =: t = query k (Strategy.pFirst t) -- | get one matched paramerer. since 0.5.0.0. -- @@ -169,7 +172,7 @@ -- @ (=!:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b -k =!: t = query k (pOne t) +k =!: t = query k (Strategy.pOne t) -- | get optional first paramerer. since 0.5.0.0. -- @@ -180,7 +183,7 @@ -- @ (=?:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -> ApiaryT (Snoc as (Maybe a)) n m b -> ApiaryT as n m b -k =?: t = query k (pOption t) +k =?: t = query k (Strategy.pOption t) -- | check parameger given and type. since 0.5.0.0. -- @@ -191,7 +194,7 @@ -- @ (?:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -> ApiaryT as n m b -> ApiaryT as n m b -k ?: t = query k (pCheck t) +k ?: t = query k (Strategy.pCheck t) -- | get many paramerer. since 0.5.0.0. -- @@ -200,7 +203,7 @@ -- @ (=*:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -> ApiaryT (Snoc as [a]) n m b -> ApiaryT as n m b -k =*: t = query k (pMany t) +k =*: t = query k (Strategy.pMany t) -- | get some paramerer. since 0.5.0.0. -- @@ -209,7 +212,7 @@ -- @ (=+:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -> ApiaryT (Snoc as [a]) n m b -> ApiaryT as n m b -k =+: t = query k (pSome t) +k =+: t = query k (Strategy.pSome t) -- | query exists checker. -- @@ -224,7 +227,7 @@ -- | check whether to exists specified header or not. since 0.6.0.0. hasHeader :: Monad n => HT.HeaderName -> ApiaryT as n m b -> ApiaryT as n m b -hasHeader n = header' pCheck ((n ==) . fst) . Just $ +hasHeader n = header' Strategy.pCheck ((n ==) . fst) . Just $ toHtml (show n) <> " header requred" -- | check whether to exists specified valued header or not. since 0.6.0.0. @@ -233,13 +236,13 @@ -> S.ByteString -- ^ header value -> ApiaryT as n m b -> ApiaryT as n m b -eqHeader k v = header' pCheck (\(k',v') -> k == k' && v == v') . Just $ +eqHeader k v = header' Strategy.pCheck (\(k',v') -> k == k' && v == v') . Just $ mconcat [toHtml $ show k, " header == ", toHtml $ show v] -- | filter by header and get first. since 0.6.0.0. header :: Monad n => HT.HeaderName -> ApiaryT (Snoc as S.ByteString) n m b -> ApiaryT as n m b -header n = header' pFirst ((n ==) . fst) . Just $ +header n = header' Strategy.pFirst ((n ==) . fst) . Just $ toHtml (show n) <> " header requred" -- | filter by headers up to 100 entries. since 0.6.0.0. diff --git a/src/Control/Monad/Apiary/Filter/Internal.hs b/src/Control/Monad/Apiary/Filter/Internal.hs --- a/src/Control/Monad/Apiary/Filter/Internal.hs +++ b/src/Control/Monad/Apiary/Filter/Internal.hs @@ -2,10 +2,12 @@ ( function, function', function_, focus ) where +import Network.Wai + import Control.Monad import Control.Monad.Apiary.Internal import Control.Monad.Apiary.Action -import Network.Wai + import Data.Apiary.SList import Data.Apiary.Document 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 @@ -15,15 +15,15 @@ import Control.Applicative import Control.Monad -import qualified Data.Text as T -import Text.Blaze.Html +import Control.Monad.Apiary.Action.Internal +import Control.Monad.Apiary.Internal import Data.Apiary.Param import Data.Apiary.SList import Data.Apiary.Document -import Control.Monad.Apiary.Action.Internal -import Control.Monad.Apiary.Internal +import qualified Data.Text as T +import Text.Blaze.Html -- | 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 diff --git a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs --- a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +++ b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs @@ -6,7 +6,9 @@ import Language.Haskell.TH import Language.Haskell.TH.Quote + import qualified Control.Monad.Apiary.Filter.Internal.Capture as Capture + import qualified Data.Text as T import Data.Proxy @@ -22,12 +24,19 @@ data Lookup = N Name | S String | None description :: String -> Q (String, Lookup) -description s = case break (== '(') s of +description s = case break (`elem` "([") s of (t, []) -> return (t, None) - (t, st) -> case break (== ')') st of - (_:'$':b, ")") -> lookupValueName b >>= + (t, st) -> case break (`elem` ")]") st of + (_:'$':b, ")") -> do + reportWarning "DEPRECATED () description. use []." + s <- lookupValueName b + maybe (fail $ b ++ " not found.") (return . (t,) . N) s + (_:b, ")") -> do + reportWarning "DEPRECATED () description. use []." + return (t, S b) + (_:'$':b, "]") -> lookupValueName b >>= maybe (fail $ b ++ " not found.") (return . (t,) . N) - (_:b, ")") -> return (t, S b) + (_:b, "]") -> return (t, S b) (_, _) -> fail "capture: syntax error." mkCap :: [String] -> ExpQ diff --git a/src/Control/Monad/Apiary/Filter/Internal/Strategy.hs b/src/Control/Monad/Apiary/Filter/Internal/Strategy.hs --- a/src/Control/Monad/Apiary/Filter/Internal/Strategy.hs +++ b/src/Control/Monad/Apiary/Filter/Internal/Strategy.hs @@ -12,17 +12,14 @@ module Control.Monad.Apiary.Filter.Internal.Strategy where -import Data.Apiary.SList -import qualified Data.Text as T -import Data.Apiary.Document - -import Data.Typeable import Data.Maybe import Data.Reflection -#if __GLASGOW_HASKELL__ < 707 -import Data.Proxy -#endif +import qualified Data.Text as T +import Data.Apiary.Proxy +import Data.Apiary.SList +import Data.Apiary.Document + class Strategy (w :: * -> *) where type SNext w (as :: [*]) a :: [*] readStrategy :: (v -> Maybe a) @@ -36,7 +33,7 @@ getQuery :: (v -> Maybe a) -> proxy (w a) -> ((k,v) -> Bool) -> [(k, v)] -> [Maybe a] getQuery readf _ kf = map readf . map snd . filter kf --- | get first matched key( [1,) params to Type.). since 0.5.0.0. +-- | get first matched key( [0,) params to Type.). since 0.5.0.0. data Option a deriving Typeable instance Strategy Option where type SNext Option as a = Snoc as (Maybe a) @@ -49,30 +46,24 @@ a:_ -> Just a strategyRep _ = StrategyRep "optional" --- | get first matched key ( [0,) params to Maybe Type.) since 0.5.0.0. +-- | get first matched key ( [1,) params to Maybe Type.) since 0.5.0.0. data First a deriving Typeable instance Strategy First where type SNext First as a = Snoc as a readStrategy rf k p q l = - let rs = getQuery rf p k q - in if any isNothing rs - then Nothing - else case catMaybes rs of - [] -> Nothing - a:_ -> Just $ sSnoc l a + case getQuery rf p k q of + Just a:_ -> Just $ sSnoc l a + _ -> Nothing strategyRep _ = StrategyRep "first" --- | get key ( [1] param to Type.) since 0.5.0.0. +-- | get key ( [1,1] param to Type.) since 0.5.0.0. data One a deriving Typeable instance Strategy One where type SNext One as a = Snoc as a readStrategy rf k p q l = - let rs = getQuery rf p k q - in if any isNothing rs - then Nothing - else case catMaybes rs of - [a] -> Just $ sSnoc l a - _ -> Nothing + case getQuery rf p k q of + [Just a] -> Just $ sSnoc l a + _ -> Nothing strategyRep _ = StrategyRep "one" -- | get parameters ( [0,) params to [Type] ) since 0.5.0.0. 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 @@ -16,42 +16,38 @@ module Control.Monad.Apiary.Internal where import Network.Wai + import Control.Applicative import Control.Monad import Control.Monad.Trans import Control.Monad.Identity import Control.Monad.Trans.Control import Control.Monad.Base +import Control.Monad.Apiary.Action.Internal + import Data.Apiary.SList import Data.Apiary.Document import Data.Monoid import Text.Blaze.Html import qualified Data.Text as T -import Control.Monad.Apiary.Action.Internal - -data ApiaryReader n c = ApiaryReader - { readerFilter :: ActionT n (SList c) - , readerConfig :: ApiaryConfig - , readerDoc :: Doc -> Doc +data ApiaryEnv n c = ApiaryEnv + { envFilter :: ActionT n (SList c) + , envConfig :: ApiaryConfig + , envDoc :: Doc -> Doc } +initialEnv :: Monad n => ApiaryConfig -> ApiaryEnv n '[] +initialEnv conf = ApiaryEnv (return SNil) conf id + data ApiaryWriter n = ApiaryWriter { writerHandler :: ActionT n () , writerDoc :: [Doc] } -instance Monad n => Monoid (ApiaryWriter n) where - mempty = ApiaryWriter mzero [] - ApiaryWriter ah ad `mappend` ApiaryWriter bh bd = - ApiaryWriter (mplus ah bh) (ad <> bd) - -initialReader :: Monad n => ApiaryConfig -> ApiaryReader n '[] -initialReader conf = ApiaryReader (return SNil) conf id - -- | most generic Apiary monad. since 0.8.0.0. newtype ApiaryT c n m a = ApiaryT { unApiaryT :: forall b. - ApiaryReader n c + ApiaryEnv n c -> (a -> ApiaryWriter n -> m b) -> m b } @@ -59,23 +55,45 @@ -- | 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 + +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 + +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 $ \rdr cont -> - unApiaryT m rdr $ \a hdr -> hdr `seq` cont (f a) hdr + fmap f m = ApiaryT $ \env cont -> + unApiaryT m env $ \a hdr -> hdr `seq` cont (f a) hdr instance Monad n => Applicative (ApiaryT c n m) where pure x = ApiaryT $ \_ cont -> cont x mempty - mf <*> ma = ApiaryT $ \rdr cont -> - unApiaryT mf rdr $ \f hdr -> - unApiaryT ma rdr $ \a hdr' -> + 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 Monad n => Monad (ApiaryT c n m) where return x = ApiaryT $ \_ cont -> cont x mempty - m >>= k = ApiaryT $ \rdr cont -> - unApiaryT m rdr $ \a hdr -> - unApiaryT (k a) rdr $ \b hdr' -> + 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'' @@ -88,16 +106,11 @@ instance (Monad n, MonadBase b m) => MonadBase b (ApiaryT c n m) where liftBase m = ApiaryT $ \_ c -> liftBase m >>= \a -> c a mempty -apiaryT :: Monad m - => (ApiaryReader n c -> m (a, ApiaryWriter n)) - -> ApiaryT c n m a -apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a,w) -> cont a w - instance Monad n => MonadTransControl (ApiaryT c n) where newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter n) } - liftWith f = apiaryT $ \rdr -> + liftWith f = apiaryT $ \env -> liftM (\a -> (a, mempty)) - (f $ \t -> liftM StTApiary' $ unApiaryT t rdr (\a w -> return (a,w))) + (f $ \t -> liftM StTApiary' $ unApiaryT t env (\a w -> return (a,w))) restoreT m = apiaryT $ \_ -> liftM unStTApiary' m instance (Monad n, MonadBaseControl b m) => MonadBaseControl b (ApiaryT c n m) where @@ -105,23 +118,13 @@ liftBaseWith = defaultLiftBaseWith StMApiary' restoreM = defaultRestoreM unStMApiary' -runApiaryT' :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig - -> ApiaryT '[] n m a -> m (Application, Documents) -runApiaryT' run conf m = unApiaryT m (initialReader conf) (\_ w -> return w) >>= \wtr -> do - let doc = docsToDocuments $ writerDoc wtr - da = maybe mzero (\f -> f doc) $ documentationAction conf - app = execActionT conf $ hoistActionT run (writerHandler wtr) `mplus` da - return (app, doc) - -runApiaryT :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig - -> ApiaryT '[] n m a -> m Application -runApiaryT run conf m = fst `liftM` runApiaryT' run conf m +-------------------------------------------------------------------------------- -runApiary :: ApiaryConfig -> Apiary '[] a -> Application -runApiary conf m = runIdentity $ runApiaryT id conf m +getApiaryEnv :: Monad n => ApiaryT c n m (ApiaryEnv n c) +getApiaryEnv = ApiaryT $ \env cont -> cont env mempty apiaryConfig :: Monad n => ApiaryT c n m ApiaryConfig -apiaryConfig = ApiaryT $ \r cont -> cont (readerConfig r) mempty +apiaryConfig = liftM envConfig getApiaryEnv addRoute :: Monad n => ApiaryWriter n -> ApiaryT c n m () addRoute r = ApiaryT $ \_ cont -> cont () r @@ -129,48 +132,53 @@ -- | filter by action. since 0.6.1.0. 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 $ \rdr cont -> unApiaryT m rdr - { readerFilter = readerFilter rdr >>= g - , readerDoc = readerDoc rdr . d +focus d g m = ApiaryT $ \env cont -> unApiaryT m env + { envFilter = envFilter env >>= g + , envDoc = envDoc env . d } cont -- | splice ActionT ApiaryT. action :: 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' a = do + env <- getApiaryEnv + addRoute $ ApiaryWriter (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 + -- | API document group. since 0.12.0.0. -- -- only top level group recognized. group :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a -group d m = ApiaryT $ \rdr cont -> unApiaryT m rdr - { readerDoc = readerDoc rdr . DocGroup d } cont +group = insDoc . DocGroup -- | add API document. since 0.12.0.0. -- -- It use only filters prior document, -- so you should be placed document directly in front of action. document :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a -document d m = ApiaryT $ \rdr cont -> unApiaryT m rdr - { readerDoc = \_ -> readerDoc rdr (Document $ Just d) } cont +document = insDoc . Document -- | add user defined precondition. since 0.13.0. precondition :: Html -> ApiaryT c n m a -> ApiaryT c n m a -precondition d m = ApiaryT $ \rdr cont -> unApiaryT m rdr - { readerDoc = readerDoc rdr . DocPrecondition d } cont +precondition = insDoc . DocPrecondition +noDoc :: ApiaryT c n m a -> ApiaryT c n m a +noDoc = insDoc DocDropNext + +-------------------------------------------------------------------------------- + {-# DEPRECATED actionWithPreAction "use action'" #-} -- | execute action before main action. since 0.4.2.0 actionWithPreAction :: 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 - -getReader :: Monad n => ApiaryT c n m (ApiaryReader n c) -getReader = ApiaryT $ \rdr cont -> cont rdr mempty - --- | like action. but not apply arguments. since 0.8.0.0. -action' :: Monad n => (SList c -> ActionT n ()) -> ApiaryT c n m () -action' a = do - rdr <- getReader - addRoute $ ApiaryWriter (readerFilter rdr >>= \c -> a c) - [readerDoc rdr $ Document Nothing] diff --git a/src/Data/Apiary/Document.hs b/src/Data/Apiary/Document.hs --- a/src/Data/Apiary/Document.hs +++ b/src/Data/Apiary/Document.hs @@ -7,24 +7,20 @@ module Data.Apiary.Document where -import Language.Haskell.TH import Control.Applicative -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString as S + import Data.Typeable import Data.Maybe -import Data.Apiary.Param -import qualified Network.HTTP.Types as HT -import Text.Blaze.Html -import Text.Blaze.Internal(attribute) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import Data.Monoid -import Data.Default.Class import Data.List import Data.Function +import Data.Apiary.Param +import Data.Apiary.Method + +import Text.Blaze.Html +import qualified Data.Text as T +import qualified Data.ByteString as S + data StrategyRep = StrategyRep { strategyInfo :: T.Text } deriving (Show, Eq) @@ -33,12 +29,17 @@ = DocPath T.Text Doc | DocRoot Doc | DocFetch TypeRep (Maybe Html) Doc - | DocMethod HT.Method Doc - | DocQuery S.ByteString StrategyRep QueryRep Html Doc - | DocGroup T.Text Doc + | DocDropNext Doc + + | DocMethod Method Doc + | DocQuery S.ByteString StrategyRep QueryRep (Maybe Html) Doc | DocPrecondition Html Doc - | Document (Maybe T.Text) + | DocGroup T.Text Doc + | Document T.Text Doc + | Action +-------------------------------------------------------------------------------- + data Route = Path T.Text Route | Fetch TypeRep (Maybe Html) Route @@ -57,14 +58,14 @@ data PathDoc = PathDoc { path :: Route - , methods :: [(HT.Method, [MethodDoc])] + , methods :: [(Method, [MethodDoc])] } data QueryDoc = QueryDoc { queryName :: S.ByteString , queryStrategy :: StrategyRep , queryRep :: QueryRep - , queryDocument :: Html + , queryDocument :: (Maybe Html) } data MethodDoc = MethodDoc @@ -73,22 +74,37 @@ , document :: T.Text } +-------------------------------------------------------------------------------- + docToDocument :: Doc -> Maybe (Maybe T.Text, PathDoc) docToDocument = \case - (DocGroup "" d') -> (Nothing,) <$> loop id (\md -> [("*", md)]) id id d' - (DocGroup g d') -> (Just g,) <$> loop id (\md -> [("*", md)]) id id d' - d' -> (Nothing,) <$> loop id (\md -> [("*", md)]) id id d' + (DocGroup "" d') -> (Nothing,) <$> loop id (\md -> [("*", md)]) id id Nothing d' + (DocGroup g d') -> (Just g,) <$> loop id (\md -> [("*", md)]) id id Nothing d' + d' -> (Nothing,) <$> loop id (\md -> [("*", md)]) id id Nothing d' where - loop ph mh qs pc (DocPath t d) = loop (ph . Path t) mh qs pc d - loop _ mh qs pc (DocRoot d) = loop (const $ Path "" End) mh qs pc d - loop ph mh qs pc (DocFetch t h d) = loop (ph . Fetch t h) mh qs pc d - loop ph _ qs pc (DocMethod m d) = loop ph (\md -> [(m, md)]) qs pc d - loop ph mh qs pc (DocQuery p s q t d) = loop ph mh (qs . (QueryDoc p s q t:)) pc d - loop ph mh qs pc (DocGroup _ d) = loop ph mh qs pc d - loop ph mh qs pc (DocPrecondition h d) = loop ph mh qs (pc . (h:)) d - loop ph mh qs pc (Document (Just t)) = Just . PathDoc (ph End) $ mh [MethodDoc (qs []) (pc []) t] - loop _ _ _ _ (Document Nothing) = Nothing + loop ph mh qs ps doc (DocDropNext d) = loop ph mh qs ps doc (dropNext d) + loop ph mh qs pc doc (DocPath t d) = loop (ph . Path t) mh qs pc doc d + loop _ mh qs pc doc (DocRoot d) = loop (const $ Path "" End) mh qs pc doc d + loop ph mh qs pc doc (DocFetch t h d) = loop (ph . Fetch t h) mh qs pc doc d + loop ph _ qs pc doc (DocMethod m d) = loop ph (\md -> [(m, md)]) qs pc doc d + loop ph mh qs pc doc (DocQuery p s q t d) = loop ph mh (qs . (QueryDoc p s q t:)) pc doc d + loop ph mh qs pc doc (DocPrecondition h d) = loop ph mh qs (pc . (h:)) doc d + loop ph mh qs pc doc (DocGroup _ d) = loop ph mh qs pc doc d + loop ph mh qs pc _ (Document t d) = loop ph mh qs pc (Just t) d + loop ph mh qs pc (Just t) Action = Just . PathDoc (ph End) $ mh [MethodDoc (qs []) (pc []) t] + loop _ _ _ _ Nothing Action = Nothing + dropNext (DocPath _ d) = d + dropNext (DocRoot d) = d + dropNext (DocFetch _ _ d) = d + dropNext (DocDropNext d) = dropNext d + dropNext (DocMethod _ d) = d + dropNext (DocQuery _ _ _ _ d) = d + dropNext (DocPrecondition _ d) = d + dropNext (DocGroup _ d) = d + dropNext (Document _ d) = d + dropNext Action = Action + mergePathDoc :: [PathDoc] -> [PathDoc] mergePathDoc [] = [] mergePathDoc (pd:pds) = merge (filter (same pd) pds) : mergePathDoc (filter (not . same pd) pds) @@ -96,7 +112,7 @@ same = (==) `on` path merge pds' = PathDoc (path pd) (mergeMethods $ methods pd ++ concatMap methods pds') -mergeMethods :: [(HT.Method, [MethodDoc])] -> [(HT.Method, [MethodDoc])] +mergeMethods :: [(Method, [MethodDoc])] -> [(Method, [MethodDoc])] mergeMethods [] = [] mergeMethods (m:ms) = merge (filter (same m) ms) : mergeMethods (filter (not . same m) ms) where @@ -117,148 +133,4 @@ trav (Nothing, _) = Nothing trav (Just a, b) = Just (a, b) -routeToHtml :: Route -> (T.Text, Html, Html) -routeToHtml = loop (1::Int) "" mempty [] - where - sp = H.span "/" ! A.class_ "splitter" - loop i e r p (Path s d) = loop i (T.concat [e, "/", s]) (r <> sp <> H.span (toHtml s) ! A.class_ "path") p d - loop i e r p (Fetch t Nothing d) = - loop (succ i) (T.concat [e, "/:", T.pack $ show t]) (r <> sp <> rpHtml (toHtml $ show t) i) p d - loop i e r p (Fetch t (Just h) d) = - loop (succ i) (T.concat [e, "/:", T.pack $ show t]) (r <> sp <> rpHtml (toHtml $ show t) i) - (p <> [H.tr $ H.td (toHtml i) <> H.td (toHtml $ show t) <> H.td h]) d - loop _ e r p End = - (e, r - , if null p - then mempty - else H.table ! A.class_ "table table-condensed route-parameters" $ - H.tr (mconcat - [ H.th ! A.class_ "col-sm-1 com-md-1" $ "#" - , H.th ! A.class_ "col-sm-1 com-md-1" $ "type" - , H.th "description" - ]) <> mconcat p - ) - -data DefaultDocumentConfig = DefaultDocumentConfig - { documentTitle :: T.Text - , documentDescription :: Maybe Html - , documentUseCDN :: Bool - } - -instance Default DefaultDocumentConfig where - def = DefaultDocumentConfig "API documentation" Nothing True - -defaultDocumentToHtml :: DefaultDocumentConfig -> Documents -> Html -defaultDocumentToHtml DefaultDocumentConfig{..} docs = - H.docTypeHtml $ H.head headH <> H.body body <> footer - where - css u = H.link ! A.rel "stylesheet" ! A.href u - js u = H.script ! A.src u $ mempty - dataToggle = attribute "data-toggle" " data-toggle=\"" - dataTarget = attribute "data-target" " data-target=\"" - - mcMap f = mconcat . map f - - cdns = mconcat - [ css "//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css" - , js "//code.jquery.com/jquery-2.1.1.min.js" - , js "//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/js/bootstrap.min.js" - ] - - embeds = $( do - let embed f p = runIO (readFile p) >>= \c -> [|$(varE f) $ preEscapedToHtml (c :: String)|] - [| mconcat - [ $(embed 'H.style "static/bootstrap.min.css") - , $(embed 'H.script "static/jquery-2.1.1.min.js") - , $(embed 'H.script "static/bootstrap.min.js") - ] - |]) - - headH = mconcat - [ H.title (toHtml documentTitle) - , if documentUseCDN then cdns else embeds - , $(runIO (readFile "static/jquery.cookie-1.4.1.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|]) - , $(runIO (readFile "static/api-documentation.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|]) - , $(runIO (readFile "static/api-documentation.min.css") >>= \c -> [|H.style $ preEscapedToHtml (c::String)|]) - ] - - htmlQR (Strict r) = toHtml (show r) - htmlQR (Nullable r) = toHtml (show r) <> "?" - htmlQR Check = "check" - - query (QueryDoc p s q t) = H.tr . mconcat $ - [ H.td (toHtml $ T.decodeUtf8 p) - , H.td (toHtml $ strategyInfo s) - , H.td (htmlQR q) - , H.td t - ] - - queriesH [] = mempty - queriesH qs = - H.div ! A.class_ "col-sm-offset-1 col-md-offset-1" $ - H.table ! A.class_ "table table-condensed" $ mconcat - [ H.caption "Query parameters" - , H.tr $ mconcat [ H.th ! A.class_ "col-sm-1 col-md-1" $ "name" - , H.th ! A.class_ "col-sm-1 col-md-1" $ "num" - , H.th ! A.class_ "col-sm-1 col-md-1" $ "type" - , H.th "description" - ] - , mcMap query qs - ] - - preconds [] = mempty - preconds p = - H.div ! A.class_ "well well-sm precondition" $ mconcat - [ H.p "Preconditions:" - , H.ul $ mcMap (\h -> H.li h) p - ] - - method (m, ms) = H.div ! A.class_ "method" $ mconcat - [ H.h4 . toHtml $ T.decodeUtf8 m - , mcMap action ms - ] - - action (MethodDoc qs pc d) = H.div ! A.class_ "action col-sm-offset-1 col-md-offset-1" $ mconcat - [ preconds pc - , H.div $ H.p (toHtml d) - , queriesH qs - ] - - pathH grp (PathDoc r ms) = - let (idnt, route, rdoc) = routeToHtml r - in H.div ! A.class_ "panel panel-default" $ mconcat - [ H.div ! A.class_ "panel-heading clearfix" - ! dataToggle "collapse" ! dataTarget (toValue $ T.concat ["[id='collapse-", grp, "-", idnt, "']"]) $ mconcat - [ H.h3 ! A.class_ "panel-title pull-left" $ route - , H.div ! A.class_ "methods" $ - mcMap ((\m -> H.div ! A.class_ "pull-right" $ toHtml (T.decodeUtf8 m)) . fst) (reverse ms) - ] - , H.div ! A.id (toValue $ T.concat ["collapse-", grp, "-", idnt]) ! A.class_ "panel-collapse collapse" $ - rdoc <> (H.div ! A.class_ "panel-body" $ mcMap method ms) - ] - - groupH (g, p) = - let gs = mcMap (pathH g) p - in H.div ! A.id (toValue $ T.append "group-" g) $ mconcat [H.h2 $ toHtml g, gs] - - doc (Documents n g) = - let ng = mcMap (pathH "") n - gs = mcMap groupH g - in (H.div ! A.id "no-group") ng <> gs - - body = H.div ! A.class_ "container" $ mconcat - [ H.div ! A.class_ "page-header" $ H.h1 (toHtml documentTitle) - , maybe mempty (H.div ! A.class_ "description") documentDescription - , doc docs - ] - - footer = H.footer $ mconcat - [ "This API documentation generated by " - , H.a ! A.href "https://github.com/philopon/apiary" $ "apiary" - , " web framework." - ] - --- | construct Html as route parameter. since 0.13.0. -rpHtml :: Html -> Int -> Html -rpHtml s i = H.span (":" <> s <> H.sup (toHtml i)) ! A.class_ "fetch" diff --git a/src/Data/Apiary/Document/Html.hs b/src/Data/Apiary/Document/Html.hs new file mode 100644 --- /dev/null +++ b/src/Data/Apiary/Document/Html.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Apiary.Document.Html where + +import Language.Haskell.TH + +import Data.Monoid +import Data.Default.Class + +import Data.Apiary.Param +import Data.Apiary.Method +import Data.Apiary.Document + +import Text.Blaze.Html +import Text.Blaze.Internal(attribute) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + + +routeToHtml :: Route -> (T.Text, Html, Html) +routeToHtml = loop (1::Int) "" mempty [] + where + sp = H.span "/" ! A.class_ "splitter" + loop i e r p (Path s d) = loop i (T.concat [e, "/", s]) (r <> sp <> H.span (toHtml s) ! A.class_ "path") p d + loop i e r p (Fetch t Nothing d) = + loop (succ i) (T.concat [e, "/:", T.pack $ show t]) (r <> sp <> rpHtml (toHtml $ show t) i) p d + loop i e r p (Fetch t (Just h) d) = + loop (succ i) (T.concat [e, "/:", T.pack $ show t]) (r <> sp <> rpHtml (toHtml $ show t) i) + (p <> [H.tr $ H.td (toHtml i) <> H.td (toHtml $ show t) <> H.td h]) d + loop _ e r p End = + (e, r + , if null p + then mempty + else H.table ! A.class_ "table table-condensed route-parameters" $ + H.tr (mconcat + [ H.th ! A.class_ "col-sm-1 com-md-1" $ "#" + , H.th ! A.class_ "col-sm-1 com-md-1" $ "type" + , H.th "description" + ]) <> mconcat p + ) + +data DefaultDocumentConfig = DefaultDocumentConfig + { documentTitle :: T.Text + , documentDescription :: Maybe Html + , documentUseCDN :: Bool + } + +instance Default DefaultDocumentConfig where + def = DefaultDocumentConfig "API documentation" Nothing True + +defaultDocumentToHtml :: DefaultDocumentConfig -> Documents -> Html +defaultDocumentToHtml DefaultDocumentConfig{..} docs = + H.docTypeHtml $ H.head headH <> H.body body <> footer + where + css u = H.link ! A.rel "stylesheet" ! A.href u + js u = H.script ! A.src u $ mempty + dataToggle = attribute "data-toggle" " data-toggle=\"" + dataTarget = attribute "data-target" " data-target=\"" + + mcMap f = mconcat . map f + + cdns = mconcat + [ css "//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css" + , js "//code.jquery.com/jquery-2.1.1.min.js" + , js "//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/js/bootstrap.min.js" + ] + + embeds = $( do + let embed f p = runIO (readFile p) >>= \c -> [|$(varE f) $ preEscapedToHtml (c :: String)|] + [| mconcat + [ $(embed 'H.style "static/bootstrap.min.css") + , $(embed 'H.script "static/jquery-2.1.1.min.js") + , $(embed 'H.script "static/bootstrap.min.js") + ] + |]) + + headH = mconcat + [ H.title (toHtml documentTitle) + , if documentUseCDN then cdns else embeds + , $(runIO (readFile "static/jquery.cookie-1.4.1.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|]) + , $(runIO (readFile "static/api-documentation.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|]) + , $(runIO (readFile "static/api-documentation.min.css") >>= \c -> [|H.style $ preEscapedToHtml (c::String)|]) + ] + + htmlQR (Strict r) = toHtml (show r) + htmlQR (Nullable r) = H.span (toHtml (show r) <> "?") ! A.title (toValue (show r) <> "(nullable)") + htmlQR Check = "check" + + noDesc = H.span "no description" ! A.class_ "no-description" + + query (QueryDoc p s q t) = H.tr . mconcat $ + [ H.td (toHtml $ T.decodeUtf8 p) + , H.td (toHtml $ strategyInfo s) + , H.td (htmlQR q) + , H.td $ maybe noDesc id t + ] + + queriesH [] = mempty + queriesH qs = + H.div ! A.class_ "col-sm-offset-1 col-md-offset-1" $ + H.table ! A.class_ "table table-condensed" $ mconcat + [ H.caption "Query parameters" + , H.tr $ mconcat [ H.th ! A.class_ "col-sm-1 col-md-1" $ "name" + , H.th ! A.class_ "col-sm-1 col-md-1" $ "num" + , H.th ! A.class_ "col-sm-1 col-md-1" $ "type" + , H.th "description" + ] + , mcMap query qs + ] + + preconds [] = mempty + preconds p = + H.div ! A.class_ "well well-sm precondition" $ mconcat + [ H.p "Preconditions:" + , H.ul $ mcMap (\h -> H.li h) p + ] + + method (m, ms) = H.div ! A.class_ "method" $ mconcat + [ H.h4 . toHtml $ T.decodeUtf8 $ renderMethod m + , mcMap action ms + ] + + action (MethodDoc qs pc d) = H.div ! A.class_ "action col-sm-offset-1 col-md-offset-1" $ mconcat + [ preconds pc + , H.div $ H.p (toHtml d) + , queriesH qs + ] + + pathH grp (PathDoc r ms) = + let (idnt, route, rdoc) = routeToHtml r + in H.div ! A.class_ "panel panel-default" $ mconcat + [ H.div ! A.class_ "panel-heading clearfix" + ! dataToggle "collapse" ! dataTarget (toValue $ T.concat ["[id='collapse-", grp, "-", idnt, "']"]) $ mconcat + [ H.h3 ! A.class_ "panel-title pull-left" $ route + , H.div ! A.class_ "methods" $ + mcMap ((\m -> H.div ! A.class_ "pull-right" $ toHtml (T.decodeUtf8 m)) . renderMethod . fst) (reverse ms) + ] + , H.div ! A.id (toValue $ T.concat ["collapse-", grp, "-", idnt]) ! A.class_ "panel-collapse collapse" $ + rdoc <> (H.div ! A.class_ "panel-body" $ mcMap method ms) + ] + + groupH (g, p) = + let gs = mcMap (pathH g) p + in H.div ! A.id (toValue $ T.append "group-" g) $ mconcat [H.h2 $ toHtml g, gs] + + doc (Documents n g) = + let ng = mcMap (pathH "") n + gs = mcMap groupH g + in (H.div ! A.id "no-group") ng <> gs + + body = H.div ! A.class_ "container" $ mconcat + [ H.div ! A.class_ "page-header" $ H.h1 (toHtml documentTitle) + , maybe mempty (H.div ! A.class_ "description") documentDescription + , doc docs + ] + + footer = H.footer $ mconcat + [ "This API documentation generated by " + , H.a ! A.href "https://github.com/philopon/apiary" $ "apiary" + , " web framework." + ] + +-- | construct Html as route parameter. since 0.13.0. +rpHtml :: Html -> Int -> Html +rpHtml s i = H.span (":" <> s <> H.sup (toHtml i)) ! A.class_ "fetch" diff --git a/src/Data/Apiary/Method.hs b/src/Data/Apiary/Method.hs new file mode 100644 --- /dev/null +++ b/src/Data/Apiary/Method.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Apiary.Method where + +import Data.String +import qualified Data.ByteString.Char8 as S + +data Method + = GET + | POST + | HEAD + | PUT + | DELETE + | TRACE + | CONNECT + | OPTIONS + | PATCH + | NonStandard S.ByteString + deriving (Eq, Ord, Read, Show) + +renderMethod :: Method -> S.ByteString +renderMethod = \case + GET -> "GET" + POST -> "POST" + HEAD -> "HEAD" + PUT -> "PUT" + DELETE -> "DELETE" + TRACE -> "TRACE" + CONNECT -> "CONNECT" + OPTIONS -> "OPTIONS" + PATCH -> "PATCH" + NonStandard a -> a +{-# INLINE renderMethod #-} + +instance IsString Method where + fromString = NonStandard . S.pack + + diff --git a/src/Data/Apiary/Param.hs b/src/Data/Apiary/Param.hs --- a/src/Data/Apiary/Param.hs +++ b/src/Data/Apiary/Param.hs @@ -16,30 +16,23 @@ module Data.Apiary.Param where -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L +import Network.Wai + import Data.Int import Data.Word import Data.Proxy +import Data.Apiary.Proxy + import Data.String(IsString) -import Data.Text.Encoding.Error import Text.Read -import Network.Wai +import Data.Text.Encoding.Error +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL -#if __GLASGOW_HASKELL__ > 707 -import qualified Data.Typeable -import Data.Typeable hiding (typeRep) -typeRep = Data.Typeable.typeRep -#else -import Data.Typeable -typeRep _ = typeOf (undefined :: a) -#endif -typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep -{-# INLINE typeRep #-} +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L jsToBool :: (IsString a, Eq a) => a -> Bool jsToBool = flip notElem jsFalse @@ -107,7 +100,9 @@ class Typeable a => Query a where readQuery :: Maybe S.ByteString -> Maybe a queryRep :: proxy a -> QueryRep - queryRep = Strict . typeRep + queryRep = Strict . qTypeRep + qTypeRep :: proxy a -> TypeRep + qTypeRep = typeRep -- | javascript boolean. -- when \"false\", \"0\", \"-0\", \"\", \"null\", \"undefined\", \"NaN\" then False, else True. since 0.6.0.0. @@ -131,34 +126,35 @@ instance Query T.Text where readQuery = fmap $ T.decodeUtf8With lenientDecode - queryRep _ = Strict (typeRep (Proxy :: Proxy Text)) + qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query TL.Text where readQuery = fmap (TL.decodeUtf8With lenientDecode . L.fromStrict) - queryRep _ = Strict (typeRep (Proxy :: Proxy Text)) + qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query S.ByteString where readQuery = id - queryRep _ = Strict (typeRep (Proxy :: Proxy Text)) + qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query L.ByteString where readQuery = fmap L.fromStrict - queryRep _ = Strict (typeRep (Proxy :: Proxy Text)) + qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query String where readQuery = fmap S.unpack - queryRep _ = Strict (typeRep (Proxy :: Proxy Text)) + qTypeRep _ = typeRep (Proxy :: Proxy Text) -- | allow no parameter. but check parameter type. instance Query a => Query (Maybe a) where readQuery (Just a) = Just `fmap` readQuery (Just a) readQuery Nothing = Just Nothing - queryRep _ = Nullable $ typeRep (Proxy :: Proxy a) + queryRep _ = Nullable $ qTypeRep (Proxy :: Proxy a) --- | always success. for exists check. +-- | always success. for check existence. instance Query () where readQuery _ = Just () - queryRep _ = Check + queryRep _ = Check + qTypeRep _ = typeOf () pBool :: Proxy Bool pBool = Proxy diff --git a/src/Data/Apiary/Proxy.hs b/src/Data/Apiary/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Apiary/Proxy.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Apiary.Proxy + ( module Export +#if __GLASGOW_HASKELL__ < 707 + , typeRep +#endif + ) where + +#if __GLASGOW_HASKELL__ > 707 +import Data.Typeable as Export +#else +import Data.Proxy as Export +import Data.Typeable as Export +typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep +typeRep _ = typeOf (undefined :: a) +{-# INLINE typeRep #-} +#endif diff --git a/src/Web/Apiary.hs b/src/Web/Apiary.hs --- a/src/Web/Apiary.hs +++ b/src/Web/Apiary.hs @@ -5,17 +5,28 @@ , module Data.Apiary.Param , act -- * reexports + , module Data.Default.Class + , module Network.HTTP.Types.Status -- | MonadIO , module Control.Monad.Trans -- | MonadPlus(..), msum, mfilter, guard , module Control.Monad + -- | Strategy Proxies + , module Control.Monad.Apiary.Filter.Internal.Strategy + -- | FilePart(..) + , module Network.Wai ) where + +import Web.Apiary.TH +import Network.Wai(FilePart(..)) +import Network.HTTP.Types.Status hiding (mkStatus) import Control.Monad.Apiary import Control.Monad.Apiary.Action -import Data.Apiary.Param - +import Control.Monad.Apiary.Filter +import Control.Monad.Apiary.Filter.Internal.Strategy (pFirst, pOne, pOption, pCheck, pMany, pSome) import Control.Monad.Trans(MonadIO(..)) import Control.Monad (MonadPlus(..), msum, mfilter, guard) -import Control.Monad.Apiary.Filter -import Web.Apiary.TH + +import Data.Default.Class +import Data.Apiary.Param diff --git a/src/Web/Apiary/TH.hs b/src/Web/Apiary/TH.hs --- a/src/Web/Apiary/TH.hs +++ b/src/Web/Apiary/TH.hs @@ -2,14 +2,18 @@ {-# LANGUAGE TemplateHaskell #-} module Web.Apiary.TH where -import Control.Monad.Apiary -import Control.Monad.Apiary.Action import Language.Haskell.TH import Language.Haskell.TH.Quote + +import Network.HTTP.Types.Status +import Network.Mime + +import Control.Monad.Apiary +import Control.Monad.Apiary.Action + import qualified Data.Text as T import qualified Data.ByteString.Char8 as S import Data.Apiary.SList -import Network.Mime numToCode :: Int -> ExpQ numToCode = \case diff --git a/static/api-documentation.min.css b/static/api-documentation.min.css --- a/static/api-documentation.min.css +++ b/static/api-documentation.min.css @@ -1,1 +1,1 @@ -.fetch{color:gray}footer{padding-top:30px;padding-bottom:50px;margin-top:20px;text-align:center;color:#777;border-top:1px solid #e5e5e5}.description{margin-bottom:20px}table{margin-top:15px !important;margin-bottom:0 !important}table.route-parameters{margin-top:0 !important;border-bottom:1px solid #ddd;background-color:#f5f5f5}.method{margin-bottom:20px;padding-bottom:10px;border-bottom:1px solid #ddd}.method:last-child{margin-bottom:0;padding-bottom:0;border-bottom:0}.methods div{margin-left:10px;color:#999}.panel-heading,h1{cursor:pointer}.precondition{margin-bottom:10px}.action{margin-bottom:20px}.action:last-child{margin-bottom:0} +.fetch{color:gray}footer{padding-top:30px;padding-bottom:50px;margin-top:20px;text-align:center;color:#777;border-top:1px solid #e5e5e5}.description{margin-bottom:20px}table{margin-top:15px !important;margin-bottom:0 !important}table.route-parameters{margin-top:0 !important;border-bottom:1px solid #ddd;background-color:#f5f5f5}.method{margin-bottom:20px;padding-bottom:10px;border-bottom:1px solid #ddd}.method:last-child{margin-bottom:0;padding-bottom:0;border-bottom:0}.methods div{margin-left:10px;color:#999}.panel-heading,h1{cursor:pointer}.precondition{margin-bottom:10px}.action{margin-bottom:20px}.action:last-child{margin-bottom:0}.no-description{color:#aaa} diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -66,8 +66,8 @@ methodFilterApp :: Application methodFilterApp = runApiary def $ do - method "GET" . action $ contentType "text/plain" >> lbs "GET" - stdMethod POST . action $ contentType "text/plain" >> lbs "POST" + method "GET" . action $ contentType "text/plain" >> lbs "GET" + method POST . action $ contentType "text/plain" >> lbs "POST" methodFilterTest :: Test methodFilterTest = testGroup "methodFilter" @@ -112,7 +112,7 @@ captureApp :: Application captureApp = runApiary def $ do [capture|/foo|] . action $ contentType "text/plain" >> lbs "foo" - [capture|/:Int|] . stdMethod GET . action $ \i -> contentType "text/plain" >> lbs (L.unwords ["Int", L.pack $ show i]) + [capture|/:Int|] . method GET . action $ \i -> contentType "text/plain" >> lbs (L.unwords ["Int", L.pack $ show i]) [capture|/:Double|] . action $ \i -> contentType "text/plain" >> lbs (L.unwords ["Double", L.pack $ show i]) [capture|/bar/:L.ByteString/:Int|] . action $ \s i -> contentType "text/plain" >> lbs (L.unwords [s, L.pack $ show i]) [capture|/:L.ByteString|] . action $ \s -> contentType "text/plain" >> lbs (L.unwords ["fall", s]) @@ -150,7 +150,7 @@ , testReq "GET /?foo=12" $ assertPlain200 "foo Int 12" app , testReq "GET /?foo=a" $ assertPlain200 "foo String \"a\"" app , testReq "GET /?foo=12&foo=23" $ assertPlain200 "foo Int 12" app - , testReq "GET /?foo=12&foo=b" $ assertPlain200 "foo String \"12\"" app + , testReq "GET /?foo=12&foo=b" $ assertPlain200 "foo Int 12" app ] where app = queryApp (=:) (=:) (=:) @@ -230,10 +230,10 @@ multipleFilter1App :: Application multipleFilter1App = runApiary def $ do root $ do - stdMethod GET . action $ contentType "text/plain" >> lbs "GET /" - stdMethod POST . action $ contentType "text/html" >> lbs "POST /" + method GET . action $ contentType "text/plain" >> lbs "GET /" + method POST . action $ contentType "text/html" >> lbs "POST /" - stdMethod DELETE . action $ contentType "text/plain" >> lbs "DELETE ANY" + method DELETE . action $ contentType "text/plain" >> lbs "DELETE ANY" multipleFilter1Test :: Test multipleFilter1Test = testGroup "multiple test1: root, method"