apiary 0.17.2 → 1.0.0
raw patch · 25 files changed
+1139/−1059 lines, 25 filesdep −tagged
Dependencies removed: tagged
Files
- CHANGELOG.md +17/−0
- apiary.cabal +14/−17
- src/Control/Monad/Apiary.hs +11/−11
- src/Control/Monad/Apiary/Action.hs +31/−26
- src/Control/Monad/Apiary/Action/Internal.hs +228/−137
- src/Control/Monad/Apiary/Filter.hs +110/−173
- src/Control/Monad/Apiary/Filter/Internal.hs +9/−7
- src/Control/Monad/Apiary/Filter/Internal/Capture.hs +29/−12
- src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +37/−22
- src/Control/Monad/Apiary/Filter/Internal/Strategy.hs +0/−161
- src/Control/Monad/Apiary/Internal.hs +47/−52
- src/Data/Apiary/Compat.hs +41/−0
- src/Data/Apiary/Dict.hs +133/−0
- src/Data/Apiary/Document.hs +8/−135
- src/Data/Apiary/Document/Html.hs +27/−16
- src/Data/Apiary/Document/Internal.hs +140/−0
- src/Data/Apiary/Extension.hs +1/−8
- src/Data/Apiary/Param.hs +135/−36
- src/Data/Apiary/Proxy.hs +0/−20
- src/Data/Apiary/SList.hs +0/−52
- src/Web/Apiary.hs +63/−13
- src/Web/Apiary/Heroku.hs +37/−25
- src/Web/Apiary/TH.hs +0/−100
- static/api-documentation.min.css +1/−1
- test/Application.hs +20/−35
CHANGELOG.md view
@@ -1,3 +1,20 @@+# 1.0.0+* included named parameter. motivation:++ changing filter order++ `filterA . filterB . action $ \a b -> act` to++ `filterB . filterA . action $ \b a -> act`+ ~~~+ changes argument order. it's too bad...++* simplified Strategy type class.+* removed DEPRECATED functions.+* changed runner type.+* changed module structure.+* API freeze. I'll pay attention to compatibility, maybe...+ # 0.17.2 * send 302 if file not midified.
apiary.cabal view
@@ -1,5 +1,5 @@ name: apiary-version: 0.17.2+version: 1.0.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.@@ -13,8 +13,9 @@ import qualified Data.ByteString.Lazy.Char8 as L . main :: IO ()- main = server (run 3000) . runApiary def $ do-   [capture|/:Int|] . ("name" =: pLazyByteString) . method GET . action $ \\age name -> do+ main = runApiary (run 3000) def $ do+   [capture|/age::Int|] . ([key|name|] =: pLazyByteString) . method GET . action $ do+       (age, name) <- [params|age,name|]       guard (age >= 18)       contentType "text/html"       mapM_ lazyBytes ["<h1>Hello, ", name, "!</h1>\\n"]@@ -31,15 +32,15 @@ 404 Page Notfound. @ .- * High performance(benchmark: <https://github.com/philopon/apiary-benchmark/tree/v0.17.0>).+ * High performance(benchmark: <https://github.com/philopon/apiary-benchmark/tree/v1.0.0>). . * 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.17.0/examples/api.hs>, <https://rawgit.com/philopon/apiary/v0.17.0/examples/api.html>).+ * Auto generate API documentation(example: <https://github.com/philopon/apiary/blob/v1.0.0/examples/api.hs>, <https://rawgit.com/philopon/apiary/v1.0.0/examples/api.html>). .- more examples: <https://github.com/philopon/apiary/blob/v0.17.0/examples/>+ more examples: <https://github.com/philopon/apiary/blob/v1.0.0/examples/> . live demo: <http://best-haskell.herokuapp.com/> (source code: <https://github.com/philopon/best-haskell>) @@ -52,7 +53,7 @@ copyright: (c) 2014 Hirotomo Moriwaki category: Web build-type: Simple-stability: experimental+stability: stable extra-source-files: static/api-documentation.min.js , static/jquery.cookie-1.4.1.min.js , static/api-documentation.min.css@@ -73,24 +74,23 @@ Control.Monad.Apiary Control.Monad.Apiary.Filter- Control.Monad.Apiary.Filter.Internal- Control.Monad.Apiary.Filter.Internal.Strategy Control.Monad.Apiary.Action Data.Apiary.Extension- Data.Apiary.Extension.Internal- Data.Apiary.SList Data.Apiary.Param+ Data.Apiary.Dict Data.Apiary.Method- Data.Apiary.Proxy+ Data.Apiary.Compat Data.Apiary.Document Data.Apiary.Document.Html - other-modules: Control.Monad.Apiary.Internal+ other-modules: Data.Apiary.Document.Internal+ Data.Apiary.Extension.Internal+ Control.Monad.Apiary.Internal+ Control.Monad.Apiary.Filter.Internal Control.Monad.Apiary.Action.Internal Control.Monad.Apiary.Filter.Internal.Capture Control.Monad.Apiary.Filter.Internal.Capture.TH- Web.Apiary.TH build-depends: base >=4.6 && <4.8 , template-haskell >=2.8 && <2.10 @@ -118,9 +118,6 @@ , process >=1.2 && <1.3 , unix-compat >=0.4 && <0.5 , http-date >=0.0 && <0.1-- if impl(ghc < 7.8)- build-depends: tagged >=0.7 && <0.8 if flag(wai3) build-depends: wai >=3.0 && <3.1
src/Control/Monad/Apiary.hs view
@@ -1,12 +1,13 @@ module Control.Monad.Apiary- ( ApiaryT, EApplication, server, serverWith- , runApiaryT+ ( ApiaryT+ -- * Runner+ -- ** Apiary -> Application+ , runApiaryTWith+ , runApiaryWith , runApiary- -- * getter- , apiaryConfig- , apiaryExt+ , ApiaryConfig(..) -- * execute action- , action, action'+ , action -- * middleware , middleware -- * API documentation@@ -14,11 +15,10 @@ , document , precondition , noDoc- , rpHtml- -- * deprecated- , actionWithPreAction+ -- * not export from Web.Apiary+ , apiaryConfig+ , apiaryExt ) where import Control.Monad.Apiary.Internal--import Data.Apiary.Document.Html (rpHtml)+import Control.Monad.Apiary.Action.Internal
src/Control/Monad/Apiary/Action.hs view
@@ -2,52 +2,57 @@ module Control.Monad.Apiary.Action ( ActionT- , ApiaryConfig(..)- , defaultDocumentationAction- , DefaultDocumentConfig(..)- -- * actions- , stop, stopWith+ -- * stop action+ , stop - -- ** getter- , getRequest- , getHeaders- , getReqParams- , File(..)- , getReqFiles- , getExt+ -- * getter+ , param+ , params - -- ** setter+ -- * setter , status- -- *** response header+ -- ** response header , addHeader, setHeaders, modifyHeader- , ContentType , contentType- -- *** response body+ -- ** response body , reset- , file- , file' , builder , bytes, lazyBytes , text, lazyText , showing , string, char- , stream- , rawResponse-- , StreamingBody+ , file -- ** monolithic action -- *** redirect , redirect, redirectPermanently, redirectTemporary++ -- *** documentation+ , defaultDocumentationAction+ , DefaultDocumentConfig(..)++ -- * not export from Web.Apiary+ , ContentType+ , stopWith+ -- ** getter+ , getRequest+ , getHeaders+ , getParams+ , getExt+ , getQueryParams+ , getReqBodyParams+ , getReqBodyFiles+ -- ** setter+ , file'+ , stream+ , rawResponse+ , StreamingBody+ -- ** redirect , redirectWith- - -- * deprecated- , redirectFound, redirectSeeOther, source, lbs ) where import Control.Monad.Apiary.Action.Internal -import Data.Apiary.Param import Data.Apiary.Document.Html #ifdef WAI3
src/Control/Monad/Apiary/Action/Internal.hs view
@@ -1,21 +1,27 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-} module Control.Monad.Apiary.Action.Internal where +import Language.Haskell.TH+import Language.Haskell.TH.Quote+ import System.PosixCompat.Files import Control.Applicative@@ -28,13 +34,15 @@ import Network.Mime hiding (Extension) import Network.HTTP.Date-import Network.HTTP.Types+import Network.HTTP.Types as Http import Network.Wai import qualified Network.Wai.Parse as P import Data.Monoid hiding (All) import Data.Apiary.Extension+import Data.Apiary.Dict import Data.Apiary.Param+import Data.Apiary.Compat import Data.Apiary.Document import Data.Apiary.Document.Html import Data.Default.Class@@ -68,7 +76,8 @@ , mimeType :: FilePath -> S.ByteString } -defaultDocumentationAction :: Monad m => DefaultDocumentConfig -> ActionT exts m ()+-- | auto generated document.+defaultDocumentationAction :: Monad m => DefaultDocumentConfig -> ActionT exts prms m () defaultDocumentationAction conf = do d <- getDocuments contentType "text/html"@@ -151,24 +160,25 @@ | Pass | Stop Response -newtype ActionT exts m a = ActionT { unActionT :: forall b. - ActionEnv exts+newtype ActionT exts prms m a = ActionT { unActionT :: forall b. + Dict prms+ -> ActionEnv exts -> ActionState -> (a -> ActionState -> m (Action b)) -> m (Action b)- }+ } deriving (Functor) -runActionT :: Monad m => ActionT exts m a- -> ActionEnv exts -> ActionState+runActionT :: Monad m => ActionT exts prms m a+ -> Dict prms -> ActionEnv exts -> ActionState -> m (Action a)-runActionT m env st = unActionT m env st $ \a !st' ->+runActionT m dict env st = unActionT m dict env st $ \a !st' -> return (Continue st' a) {-# INLINE runActionT #-} actionT :: Monad m - => (ActionEnv exts -> ActionState -> m (Action a))- -> ActionT exts m a-actionT f = ActionT $ \env !st cont -> f env st >>= \case+ => (Dict prms -> ActionEnv exts -> ActionState -> m (Action a))+ -> ActionT exts prms m a+actionT f = ActionT $ \dict env !st cont -> f dict env st >>= \case Pass -> return Pass Stop s -> return $ Stop s Continue !st' a -> cont a st'@@ -176,17 +186,48 @@ -- | n must be Monad, so cant be MFunctor. hoistActionT :: (Monad m, Monad n)- => (forall b. m b -> n b) -> ActionT exts m a -> ActionT exts n a-hoistActionT run m = actionT $ \e s -> run (runActionT m e s)+ => (forall b. m b -> n b) -> ActionT exts prms m a -> ActionT exts prms n a+hoistActionT run m = actionT $ \d e s -> run (runActionT m d e s) {-# INLINE hoistActionT #-} -execActionT :: ApiaryConfig -> Extensions exts -> Documents -> ActionT exts IO () -> Application+newtype ActionT' exts m a = ActionT' { unActionT' :: forall b. + ActionEnv exts+ -> ActionState+ -> (a -> ActionState -> m (Action b))+ -> m (Action b)+ } deriving (Functor)++applyDict :: Dict prms -> ActionT exts prms m a -> ActionT' exts m a+applyDict d (ActionT m) = ActionT' (m d)+{-# INLINE applyDict #-}++actionT' :: Monad m + => (ActionEnv exts -> ActionState -> m (Action a))+ -> ActionT' exts m a+actionT' f = ActionT' $ \env !st cont -> f env st >>= \case+ Pass -> return Pass+ Stop s -> return $ Stop s+ Continue !st' a -> cont a st'+{-# INLINE actionT' #-}++runActionT' :: Monad m => ActionT' exts m a+ -> ActionEnv exts -> ActionState+ -> m (Action a)+runActionT' m env st = unActionT' m env st $ \a !st' -> return (Continue st' a)+{-# INLINE runActionT' #-}++hoistActionT' :: (Monad m, Monad n)+ => (forall b. m b -> n b) -> ActionT' exts m a -> ActionT' exts n a+hoistActionT' run m = actionT' $ \e s -> run (runActionT' m e s)+{-# INLINE hoistActionT' #-}++execActionT' :: ApiaryConfig -> Extensions exts -> Documents -> ActionT' exts IO () -> Application #ifdef WAI3-execActionT config exts doc m request send = +execActionT' config exts doc m request send = #else-execActionT config exts doc m request = let send = return in+execActionT' config exts doc m request = let send = return in #endif- runActionT m (ActionEnv config request doc exts) (initialState config) >>= \case+ runActionT' m (ActionEnv config request doc exts) (initialState config) >>= \case #ifdef WAI3 Pass -> notFound config request send #else@@ -195,109 +236,171 @@ Stop s -> send s Continue r _ -> send $ toResponse r ---------------------------------------------------------------------------------+instance Applicative (ActionT' exts m) where+ pure x = ActionT' $ \_ !st cont -> cont x st+ mf <*> ma = ActionT' $ \env st cont ->+ unActionT' mf env st $ \f !st' ->+ unActionT' ma env st' $ \a !st'' ->+ cont (f a) st'' -instance Functor (ActionT exts m) where- fmap f m = ActionT $ \env st cont ->- unActionT m env st (\a !s' -> cont (f a) s')+instance Monad m => Monad (ActionT' exts m) where+ return x = ActionT' $ \_ !st cont -> cont x st+ m >>= k = ActionT' $ \env !st cont ->+ unActionT' m env st $ \a !st' ->+ unActionT' (k a) env st' cont+ fail s = ActionT' $ \(ActionEnv{actionConfig = c}) _ _ -> return $+ Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s) -instance Applicative (ActionT exts m) where- pure x = ActionT $ \_ !st cont -> cont x st- mf <*> ma = ActionT $ \env st cont ->- unActionT mf env st $ \f !st' ->- unActionT ma env st' $ \a !st'' ->+instance (Monad m, Functor m) => Alternative (ActionT' exts m) where+ empty = mzero+ (<|>) = mplus+ {-# INLINE empty #-}+ {-# INLINE (<|>) #-}++instance Monad m => MonadPlus (ActionT' exts m) where+ mzero = ActionT' $ \_ _ _ -> return Pass+ mplus m n = ActionT' $ \e !s cont -> unActionT' m e s cont >>= \case+ Continue !st a -> return $ Continue st a+ Stop stp -> return $ Stop stp+ Pass -> unActionT' n e s cont+ {-# INLINE mzero #-}+ {-# INLINE mplus #-}+--------------------------------------------------------------------------------++instance Applicative (ActionT exts prms m) where+ pure x = ActionT $ \_ _ !st cont -> cont x st+ mf <*> ma = ActionT $ \dict env st cont ->+ unActionT mf dict env st $ \f !st' ->+ unActionT ma dict env st' $ \a !st'' -> cont (f a) st'' -instance Monad m => Monad (ActionT exts m) where- return x = ActionT $ \_ !st cont -> cont x st- m >>= k = ActionT $ \env !st cont ->- unActionT m env st $ \a !st' ->- unActionT (k a) env st' cont- fail s = ActionT $ \(ActionEnv{actionConfig = c}) _ _ -> return $+instance Monad m => Monad (ActionT exts prms m) where+ return x = ActionT $ \_ _ !st cont -> cont x st+ m >>= k = ActionT $ \dict env !st cont ->+ unActionT m dict env st $ \a !st' ->+ unActionT (k a) dict env st' cont+ fail s = ActionT $ \_ (ActionEnv{actionConfig = c}) _ _ -> return $ Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s) -instance MonadIO m => MonadIO (ActionT exts m) where- liftIO m = ActionT $ \_ !st cont ->+instance MonadIO m => MonadIO (ActionT exts prms m) where+ liftIO m = ActionT $ \_ _ !st cont -> liftIO m >>= \a -> cont a st -instance MonadTrans (ActionT exts) where- lift m = ActionT $ \_ !st cont ->+instance MonadTrans (ActionT exts prms) where+ lift m = ActionT $ \_ _ !st cont -> m >>= \a -> cont a st -instance MonadThrow m => MonadThrow (ActionT exts m) where- throwM e = ActionT $ \_ !st cont ->+instance MonadThrow m => MonadThrow (ActionT exts prms m) where+ throwM e = ActionT $ \_ _ !st cont -> throwM e >>= \a -> cont a st -instance MonadCatch m => MonadCatch (ActionT exts m) where- catch m h = ActionT $ \env !st cont ->- catch (unActionT m env st cont) (\e -> unActionT (h e) env st cont)+instance MonadCatch m => MonadCatch (ActionT exts prms m) where+ catch m h = ActionT $ \dict env !st cont ->+ catch (unActionT m dict env st cont) (\e -> unActionT (h e) dict env st cont) {-# INLINE catch #-} -instance MonadMask m => MonadMask (ActionT exts m) where- mask a = ActionT $ \env !st cont ->- mask $ \u -> unActionT (a $ q u) env st cont+instance MonadMask m => MonadMask (ActionT exts prms m) where+ mask a = ActionT $ \dict env !st cont ->+ mask $ \u -> unActionT (a $ q u) dict env st cont where- q u m = actionT $ \env !st -> u (runActionT m env st)- uninterruptibleMask a = ActionT $ \env !st cont ->- uninterruptibleMask $ \u -> unActionT (a $ q u) env st cont+ q u m = actionT $ \dict env !st -> u (runActionT m dict env st)+ uninterruptibleMask a = ActionT $ \dict env !st cont ->+ uninterruptibleMask $ \u -> unActionT (a $ q u) dict env st cont where- q u m = actionT $ \env !st -> u (runActionT m env st)+ q u m = actionT $ \dict env !st -> u (runActionT m dict env st) {-# INLINE mask #-} {-# INLINE uninterruptibleMask #-} -instance (Monad m, Functor m) => Alternative (ActionT exts m) where+instance (Monad m, Functor m) => Alternative (ActionT exts prms m) where empty = mzero (<|>) = mplus {-# INLINE empty #-} {-# INLINE (<|>) #-} -instance Monad m => MonadPlus (ActionT exts m) where- mzero = ActionT $ \_ _ _ -> return Pass- mplus m n = ActionT $ \e !s cont -> unActionT m e s cont >>= \case+instance Monad m => MonadPlus (ActionT exts prms m) where+ mzero = ActionT $ \_ _ _ _ -> return Pass+ mplus m n = ActionT $ \dict e !s cont -> unActionT m dict e s cont >>= \case Continue !st a -> return $ Continue st a Stop stp -> return $ Stop stp- Pass -> unActionT n e s cont+ Pass -> unActionT n dict e s cont {-# INLINE mzero #-} {-# INLINE mplus #-} -instance MonadBase b m => MonadBase b (ActionT exts m) where+instance MonadBase b m => MonadBase b (ActionT exts prms m) where liftBase = liftBaseDefault -instance MonadTransControl (ActionT exts) where- newtype StT (ActionT exts) a = StActionT { unStActionT :: Action a }- liftWith f = actionT $ \e !s -> - liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t e s)- restoreT m = actionT $ \_ _ -> liftM unStActionT m+instance MonadTransControl (ActionT exts prms) where+ newtype StT (ActionT exts prms) a = StActionT { unStActionT :: Action a }+ liftWith f = actionT $ \prms e !s -> + liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t prms e s)+ restoreT m = actionT $ \_ _ _ -> liftM unStActionT m -instance MonadBaseControl b m => MonadBaseControl b (ActionT exts m) where- newtype StM (ActionT exts m) a = StMT { unStMT :: ComposeSt (ActionT exts) m a }- liftBaseWith = defaultLiftBaseWith StMT- restoreM = defaultRestoreM unStMT+instance MonadBaseControl b m => MonadBaseControl b (ActionT exts prms m) where+ newtype StM (ActionT exts prms m) a = StMActionT { unStMActionT :: ComposeSt (ActionT exts prms) m a }+ liftBaseWith = defaultLiftBaseWith StMActionT+ restoreM = defaultRestoreM unStMActionT -instance MonadReader r m => MonadReader r (ActionT exts m) where+instance MonadReader r m => MonadReader r (ActionT exts prms m) where ask = lift ask local f = hoistActionT $ local f -------------------------------------------------------------------------------- -getEnv :: Monad m => ActionT exts m (ActionEnv exts)-getEnv = ActionT $ \e s c -> c e s+getEnv :: Monad m => ActionT exts prms m (ActionEnv exts)+getEnv = ActionT $ \_ e s c -> c e s +getRequest' :: Monad m => ActionT' exts m Request+getRequest' = ActionT' $ \e s c -> c (actionRequest e) s+ -- | get raw request. since 0.1.0.0.-getRequest :: Monad m => ActionT exts m Request+getRequest :: Monad m => ActionT exts prms m Request getRequest = liftM actionRequest getEnv -getConfig :: Monad m => ActionT exts m ApiaryConfig+getConfig :: Monad m => ActionT exts prms m ApiaryConfig getConfig = liftM actionConfig getEnv -getExt :: (Has e exts, Monad m) => proxy e -> ActionT exts m e+-- | get extension.+getExt :: (Has e exts, Monad m) => proxy e -> ActionT exts prms m e getExt p = liftM (getExtension p . actionExts) getEnv -getDocuments :: Monad m => ActionT exts m Documents+getParams :: Monad m => ActionT exts prms m (Dict prms)+getParams = ActionT $ \d _ s c -> c d s++-- | get parameter. since 1.0.0.+--+-- example:+--+-- > param [key|foo|]+--+param :: (Member k v prms, Monad m) => proxy k -> ActionT exts prms m v+param p = liftM (get p) getParams++paramsE :: [String] -> ExpQ+paramsE ps = do+ ns <- mapM (\p -> (,) <$> newName "x" <*> pure p) ps+ let bs = map (\(v, k) -> bindS (varP v) (prm k)) ns+ tpl = noBindS [| return $(tupE $ map (varE . fst) ns) |]+ doE $ bs ++ [tpl]+ where+ prm n = [| param (SProxy :: SProxy $(litT $ strTyLit n)) |]++-- | get parameters. since 1.0.0.+--+-- > [params|foo,bar|] == do { a <- param [key|foo|]; b <- param [key|bar|]; return (a, b) }+--+params :: QuasiQuoter+params = QuasiQuoter+ { quoteExp = paramsE . map (T.unpack . T.strip) . T.splitOn "," . T.pack+ , quotePat = error "params QQ is defined only exp."+ , quoteType = error "params QQ is defined only exp."+ , quoteDec = error "params QQ is defined only exp."+ }++getDocuments :: Monad m => ActionT exts prms m Documents getDocuments = liftM actionDocuments getEnv -getRequestBody :: MonadIO m => ActionT exts m ([Param], [File])-getRequestBody = ActionT $ \e s c -> case actionReqBody s of+getRequestBody :: MonadIO m => ActionT exts prms m ([Param], [File])+getRequestBody = ActionT $ \_ e s c -> case actionReqBody s of Just b -> c b s Nothing -> do (p,f) <- liftIO $ P.parseRequestBody P.lbsBackEnd (actionRequest e)@@ -306,59 +409,65 @@ 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 exts m [Param]-getReqParams = fst <$> getRequestBody+getQueryParams :: Monad m => ActionT exts prms m Http.Query+getQueryParams = queryString <$> getRequest +-- | parse request body and return params. since 1.0.0.+getReqBodyParams :: MonadIO m => ActionT exts prms m [Param]+getReqBodyParams = fst <$> getRequestBody+ -- | parse request body and return files. since 0.9.0.0.-getReqFiles :: MonadIO m => ActionT exts m [File]-getReqFiles = snd <$> getRequestBody+getReqBodyFiles :: MonadIO m => ActionT exts prms m [File]+getReqBodyFiles = snd <$> getRequestBody -------------------------------------------------------------------------------- -modifyState :: Monad m => (ActionState -> ActionState) -> ActionT exts m ()-modifyState f = ActionT $ \_ s c -> c () (f s)+modifyState' :: Monad m => (ActionState -> ActionState) -> ActionT' exts m ()+modifyState' f = ActionT' $ \_ s c -> c () (f s) -getState :: ActionT exts m ActionState-getState = ActionT $ \_ s c -> c s s+modifyState :: Monad m => (ActionState -> ActionState) -> ActionT exts prms m ()+modifyState f = ActionT $ \_ _ s c -> c () (f s) +getState :: ActionT exts prms m ActionState+getState = ActionT $ \_ _ s c -> c s s+ -- | set status code. since 0.1.0.0.-status :: Monad m => Status -> ActionT exts m ()+status :: Monad m => Status -> ActionT exts prms m () status st = modifyState (\s -> s { actionStatus = st } ) -- | get all request headers. since 0.6.0.0.-getHeaders :: Monad m => ActionT exts m RequestHeaders+getHeaders :: Monad m => ActionT exts prms m RequestHeaders getHeaders = requestHeaders `liftM` getRequest -- | modify response header. since 0.1.0.0.-modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT exts m ()+modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT exts prms m () modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } ) -- | add response header. since 0.1.0.0.-addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT exts m ()+addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT exts prms m () addHeader h v = modifyHeader ((h,v):) -- | set response headers. since 0.1.0.0.-setHeaders :: Monad m => ResponseHeaders -> ActionT exts m ()+setHeaders :: Monad m => ResponseHeaders -> ActionT exts prms m () setHeaders hs = modifyHeader (const hs) type ContentType = S.ByteString -- | set content-type header. -- if content-type header already exists, replace it. since 0.1.0.0.-contentType :: Monad m => ContentType -> ActionT exts m ()+contentType :: Monad m => ContentType -> ActionT exts prms m () 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 exts m a-stop = ActionT $ \_ s _ -> return $ Stop (toResponse s)+stop :: Monad m => ActionT exts prms m a+stop = ActionT $ \_ _ s _ -> return $ Stop (toResponse s) -- | stop with response. since 0.4.2.0.-stopWith :: Monad m => Response -> ActionT exts m a-stopWith a = ActionT $ \_ _ _ -> return $ Stop a+stopWith :: Monad m => Response -> ActionT exts prms m a+stopWith a = ActionT $ \_ _ _ _ -> return $ Stop a -- | redirect handler --@@ -368,7 +477,7 @@ redirectWith :: Monad m => Status -> S.ByteString -- ^ Location redirect to- -> ActionT exts m ()+ -> ActionT exts prms m () redirectWith st url = do status st addHeader "location" url@@ -383,7 +492,7 @@ -- 307 TemporaryRedirect -- | redirect with 301 Moved Permanently. since 0.3.3.0.-redirectPermanently :: Monad m => S.ByteString -> ActionT exts m ()+redirectPermanently :: Monad m => S.ByteString -> ActionT exts prms m () redirectPermanently = redirectWith movedPermanently301 -- | redirect with:@@ -392,7 +501,7 @@ -- 302 Moved Temporarily (Other) -- -- since 0.6.2.0.-redirect :: Monad m => S.ByteString -> ActionT exts m ()+redirect :: Monad m => S.ByteString -> ActionT exts prms m () redirect to = do v <- httpVersion <$> getRequest if v == http11@@ -405,7 +514,7 @@ -- 302 Moved Temporarily (Other) -- -- since 0.3.3.0.-redirectTemporary :: Monad m => S.ByteString -> ActionT exts m ()+redirectTemporary :: Monad m => S.ByteString -> ActionT exts prms m () redirectTemporary to = do v <- httpVersion <$> getRequest if v == http11@@ -417,25 +526,25 @@ -- example(use pipes-wai) -- -- @--- producer :: Monad m => Producer (Flush Builder) IO () -> ActionT exts m ()+-- producer :: Monad m => Producer (Flush Builder) IO () -> ActionT' exts m () -- producer = response (\s h -> responseProducer s h) -- @ ---rawResponse :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT exts m ()+rawResponse :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT exts prms m () rawResponse f = modifyState (\s -> s { actionResponse = ResponseFunc f } ) -- | reset response body to no response. since v0.15.2.-reset :: Monad m => ActionT exts m ()+reset :: Monad m => ActionT exts prms m () reset = modifyState (\s -> s { actionResponse = mempty } ) -- | set response body file content, without set Content-Type. since 0.1.0.0.-file' :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts m ()+file' :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts prms m () file' f p = modifyState (\s -> s { actionResponse = ResponseFile f p } ) -- | set response body file content and detect Content-Type by extension. since 0.1.0.0. -- -- file modification check since 0.17.2.-file :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts m ()+file :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts prms m () file f p = do mbims <- (>>= parseHTTPDate) . lookup "If-Modified-Since" <$> getHeaders e <- liftIO $ fileExist f@@ -451,55 +560,37 @@ file' f p -- | append response body from builder. since 0.1.0.0.-builder :: Monad m => Builder -> ActionT exts m ()+builder :: Monad m => Builder -> ActionT exts prms m () builder b = modifyState (\s -> s { actionResponse = actionResponse s <> ResponseBuilder b } ) -- | append response body from strict bytestring. since 0.15.2.-bytes :: Monad m => S.ByteString -> ActionT exts m ()+bytes :: Monad m => S.ByteString -> ActionT exts prms m () bytes = builder . B.fromByteString -- | append response body from lazy bytestring. since 0.15.2.-lazyBytes :: Monad m => L.ByteString -> ActionT exts m ()+lazyBytes :: Monad m => L.ByteString -> ActionT exts prms m () lazyBytes = builder . B.fromLazyByteString -- | append response body from strict text. encoding UTF-8. since 0.15.2.-text :: Monad m => T.Text -> ActionT exts m ()+text :: Monad m => T.Text -> ActionT exts prms m () text = builder . B.fromText -- | append response body from lazy text. encoding UTF-8. since 0.15.2.-lazyText :: Monad m => TL.Text -> ActionT exts m ()+lazyText :: Monad m => TL.Text -> ActionT exts prms m () lazyText = builder . B.fromLazyText -- | append response body from show. encoding UTF-8. since 0.15.2.-showing :: (Monad m, Show a) => a -> ActionT exts m ()+showing :: (Monad m, Show a) => a -> ActionT exts prms m () showing = builder . B.fromShow -- | append response body from string. encoding UTF-8. since 0.15.2.-string :: Monad m => String -> ActionT exts m ()+string :: Monad m => String -> ActionT exts prms m () string = builder . B.fromString -- | append response body from char. encoding UTF-8. since 0.15.2.-char :: Monad m => Char -> ActionT exts m ()+char :: Monad m => Char -> ActionT exts prms m () char = builder . B.fromChar -- | set response body source. since 0.9.0.0.-stream :: Monad m => StreamingBody -> ActionT exts m ()+stream :: Monad m => StreamingBody -> ActionT exts prms m () stream str = modifyState (\s -> s { actionResponse = ResponseStream str })--{-# DEPRECATED source "use stream" #-}-source :: Monad m => StreamingBody -> ActionT exts m ()-source = stream--{-# DEPRECATED redirectFound, redirectSeeOther "use redirect" #-}--- | redirect with 302 Found. since 0.3.3.0.-redirectFound :: Monad m => S.ByteString -> ActionT exts m ()-redirectFound = redirectWith found302---- | redirect with 303 See Other. since 0.3.3.0.-redirectSeeOther :: Monad m => S.ByteString -> ActionT exts m ()-redirectSeeOther = redirectWith seeOther303--{-# DEPRECATED lbs "use lazyBytes" #-}--- | append response body from lazy bytestring. since 0.1.0.0.-lbs :: Monad m => L.ByteString -> ActionT exts m ()-lbs = lazyBytes
src/Control/Monad/Apiary/Filter.hs view
@@ -8,48 +8,50 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Control.Monad.Apiary.Filter (- -- * filters- -- ** http method+ -- * http method method- -- ** http version- , Control.Monad.Apiary.Filter.httpVersion+ -- * http version , http09, http10, http11- -- ** path matcher+ -- * path matcher , root , capture- , Capture.path- , Capture.endPath- , Capture.fetch-- -- ** query matcher- , QueryKey(..), (??)- , query- -- *** specified operators- , (=:), (=!:), (=?:), (=?!:), (?:), (=*:), (=+:)- , hasQuery+ -- * query matcher+ , (??)+ , (=:), (=!:), (=?:), (=?!:), (=*:), (=+:) , switchQuery - -- ** header matcher- , hasHeader+ -- * header matcher , eqHeader- , headers , header- , header' , accept - -- ** other+ -- * other , ssl++ -- * not export from Web.Apiary+ , HasDesc(..)+ , QueryKey(..)+ , query+ , Control.Monad.Apiary.Filter.httpVersion+ , Capture.path+ , Capture.endPath+ , Capture.fetch+ , Capture.restPath+ , Capture.anyPath++ , function, function', function_, focus+ , Doc(..) - -- * deprecated- , stdMethod- , anyPath ) where import Network.Wai as Wai-import Network.Wai.Parse-import qualified Network.HTTP.Types as HT+import Network.Wai.Parse (parseContentType)+import qualified Network.HTTP.Types as Http import Control.Applicative import Control.Monad@@ -59,20 +61,18 @@ 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 qualified Data.Text as T import qualified Data.Text.Encoding as T+import qualified Data.CaseInsensitive as CI import Data.Monoid-import Data.Proxy-import Data.Apiary.SList-import Data.String+import Data.Apiary.Compat+import Data.Apiary.Dict import Data.Apiary.Param-import Data.Apiary.Document import Data.Apiary.Method -- | filter by HTTP method. since 0.1.0.0.@@ -82,222 +82,159 @@ -- method \"HOGE\" -- non standard method -- @ method :: Monad actM => Method -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-method m = focus' (DocMethod m) (Just m) id return--{-# DEPRECATED stdMethod "use method" #-}--- | filter by HTTP method using StdMethod. since 0.1.0.0.-stdMethod :: Monad actM => Method -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-stdMethod = method+method m = focus' (DocMethod m) (Just m) id getParams -- | filter by ssl accessed. since 0.1.0.0. ssl :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () ssl = function_ (DocPrecondition "SSL required") isSecure -- | http version filter. since 0.5.0.0.-httpVersion :: Monad actM => HT.HttpVersion -> Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+httpVersion :: Monad actM => Http.HttpVersion -> Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () httpVersion v h = function_ (DocPrecondition h) $ (v ==) . Wai.httpVersion -- | http/0.9 only accepted fiter. since 0.5.0.0. http09 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-http09 = Control.Monad.Apiary.Filter.httpVersion HT.http09 "HTTP/0.9 only"+http09 = Control.Monad.Apiary.Filter.httpVersion Http.http09 "HTTP/0.9 only" -- | http/1.0 only accepted fiter. since 0.5.0.0. http10 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-http10 = Control.Monad.Apiary.Filter.httpVersion HT.http10 "HTTP/1.0 only"+http10 = Control.Monad.Apiary.Filter.httpVersion Http.http10 "HTTP/1.0 only" -- | http/1.1 only accepted fiter. since 0.5.0.0. http11 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-http11 = Control.Monad.Apiary.Filter.httpVersion HT.http11 "HTTP/1.1 only"+http11 = Control.Monad.Apiary.Filter.httpVersion Http.http11 "HTTP/1.1 only" -- | filter by 'Control.Monad.Apiary.Action.rootPattern' of 'Control.Monad.Apiary.Action.ApiaryConfig'. root :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-root = focus' DocRoot Nothing (RootPath:) return--{-# DEPRECATED anyPath "use greedy filter [capture|/**|] or use restPath." #-}--- | match all subsequent path. since 0.15.0.-anyPath :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-anyPath = focus' id Nothing (RestPath:) return+root = focus' DocRoot Nothing (RootPath:) getParams -------------------------------------------------------------------------------- -data QueryKey = QueryKey- { queryKey :: S.ByteString- , queryDesc :: Maybe Html- }--instance IsString QueryKey where- fromString s = QueryKey (SC.pack s) Nothing--(??) :: QueryKey -> Html -> QueryKey-QueryKey k _ ?? d = QueryKey k (Just d)+newtype QueryKey (key :: Symbol) = QueryKey { queryKeyDesc :: Maybe Html } --- | low level query getter. since 0.5.0.0.------ @--- query "key" (Proxy :: Proxy (fetcher type))--- @+-- | add document to query parameter filter. ----- examples:+-- > [key|key|] ?? "document" =: pInt ----- @--- query "key" ('First' :: First Int) -- get first \'key\' query parameter as Int.--- query "key" ('Option' :: Option (Maybe Int)) -- get first \'key\' query parameter as Int. allow without param or value.--- query "key" ('Many' :: Many String) -- get all \'key\' query parameter as String.--- @-query :: forall exts prms actM a w m. - (ReqParam a, Strategy.Strategy w, MonadIO actM)- => QueryKey- -> w a- -> ApiaryT exts (Strategy.SNext w prms a) actM m ()- -> ApiaryT exts prms actM m ()-query QueryKey{..} p =- focus doc $ \l -> do- r <- getRequest- (q,f) <- getRequestBody+(??) :: proxy key -> Html -> QueryKey key+_ ?? d = QueryKey (Just d) - maybe mzero return $- Strategy.readStrategy id ((queryKey ==) . fst) p - (reqParams p r q f) l- where- doc = DocQuery queryKey (Strategy.strategyRep p) (reqParamRep (Proxy :: Proxy a)) queryDesc+class HasDesc (a :: Symbol -> *) where+ queryDesc :: a key -> Maybe Html +instance HasDesc QueryKey where+ queryDesc = queryKeyDesc++instance HasDesc Proxy where+ queryDesc = const Nothing++instance HasDesc SProxy where+ queryDesc = const Nothing++-- type SNext w (k::Symbol) a (prms :: [(Symbol, *)]) :: [(Symbol, *)]+query :: forall query strategy k v exts prms actM m. (NotMember k prms, MonadIO actM, KnownSymbol k, ReqParam v, HasDesc query, Strategy strategy)+ => query k -> strategy v -> ApiaryT exts (SNext strategy k v prms) actM m () -> ApiaryT exts prms actM m ()+query k w = focus (DocQuery (T.pack $ symbolVal k) (strategyRep w) (reqParamRep (Proxy :: Proxy v)) (queryDesc k)) $ do+ qs <- getQueryParams+ (ps,fs) <- getRequestBody+ let as = map snd . filter ((SC.pack (symbolVal k) ==) . fst) $ reqParams (Proxy :: Proxy v) qs ps fs+ maybe mzero return . strategy w k as =<< getParams+ -- | get first matched paramerer. since 0.5.0.0. -- -- @--- "key" =: pInt == query "key" (pFirst pInt) == query "key" (First :: First Int)+-- [key|key|] =: pInt -- @-(=:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p- -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m ()-k =: t = query k (Strategy.pFirst t)+(=:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, NotMember k prms)+ => query k -> proxy v -> ApiaryT exts (k := v ': prms) actM m () -> ApiaryT exts prms actM m ()+k =: v = query k (pFirst v) -- | get one matched paramerer. since 0.5.0.0. -- -- when more one parameger given, not matched. -- -- @--- "key" =: pInt == query "key" (pOne pInt) == query "key" (One :: One Int)+-- [key|key|] =!: pInt -- @-(=!:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p- -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m ()-k =!: t = query k (Strategy.pOne t)+(=!:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, NotMember k prms)+ => query k -> proxy v -> ApiaryT exts (k := v ': prms) actM m () -> ApiaryT exts prms actM m ()+k =!: t = query k (pOne t) -- | get optional first paramerer. since 0.5.0.0. -- -- when illegal type parameter given, fail match(don't give Nothing). -- -- @--- "key" =: pInt == query "key" (pOption pInt) == query "key" (Option :: Option Int)+-- [key|key|] =?: pInt -- @-(=?:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p- -> ApiaryT exts (Maybe p ': prms) actM m () -> ApiaryT exts prms actM m ()-k =?: t = query k (Strategy.pOption t)+(=?:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, NotMember k prms)+ => query k -> proxy v+ -> ApiaryT exts (k := Maybe v ': prms) actM m () -> ApiaryT exts prms actM m ()+k =?: t = query k (pOption t) -- | get optional first paramerer with default. since 0.16.0. -- -- when illegal type parameter given, fail match(don't give Nothing). -- -- @--- "key" =: (0 :: Int) == query "key" (pOptional (0 :: Int)) == query "key" (Optional 0 :: Optional Int)--- @-(=?!:) :: (MonadIO actM, ReqParam p, Show p) => QueryKey -> p- -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m ()-k =?!: v = query k (Strategy.pOptional v)---- | check parameger given and type. since 0.5.0.0.------ If you wan't to allow any type, give 'pVoid'.------ @--- "key" =: pInt == query "key" (pCheck pInt) == query "key" (Check :: Check Int)+-- [key|key|] =!?: (0 :: Int) -- @-(?:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p- -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-k ?: t = query k (Strategy.pCheck t)+(=?!:) :: forall query k v exts prms actM m. (HasDesc query, MonadIO actM, Show v, ReqParam v, KnownSymbol k, NotMember k prms)+ => query k -> v+ -> ApiaryT exts (k := v ': prms) actM m () -> ApiaryT exts prms actM m ()+k =?!: v = query k (pOptional v) -- | get many paramerer. since 0.5.0.0. -- -- @--- "key" =: pInt == query "key" (pMany pInt) == query "key" (Many :: Many Int)+-- [key|key|] =*: pInt -- @-(=*:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p- -> ApiaryT exts ([p] ': prms) actM m () -> ApiaryT exts prms actM m ()-k =*: t = query k (Strategy.pMany t)+(=*:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, NotMember k prms)+ => query k -> proxy v+ -> ApiaryT exts (k := [v] ': prms) actM m () -> ApiaryT exts prms actM m ()+k =*: t = query k (pMany t) -- | get some paramerer. since 0.5.0.0. -- -- @--- "key" =: pInt == query "key" (pSome pInt) == query "key" (Some :: Some Int)--- @-(=+:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p- -> ApiaryT exts ([p] ': prms) actM m () -> ApiaryT exts prms actM m ()-k =+: t = query k (Strategy.pSome t)---- | query exists checker.------ @--- hasQuery q = 'query' q (Check :: 'Check' ())+-- [key|key|] =+: pInt -- @----hasQuery :: MonadIO actM => QueryKey -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-hasQuery q = query q (Strategy.Check :: Strategy.Check ())+(=+:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, NotMember k prms)+ => query k -> proxy v+ -> ApiaryT exts (k := [v] ': prms) actM m () -> ApiaryT exts prms actM m ()+k =+: t = query k (pSome t) -- | get existance of key only query parameter. since v0.17.0.-switchQuery :: Monad actM => QueryKey -> ApiaryT exts (Bool ': prms) actM m () -> ApiaryT exts prms actM m ()-switchQuery QueryKey{..} = focus doc $ \l -> do- r <- getRequest- return $ (not . null $ filter (\(k,v) -> queryKey == k && checkValue v) (queryString r)) ::: l- where- doc = DocQuery queryKey (StrategyRep "Switch") NoValue queryDesc- checkValue Nothing = True- checkValue v = case readQuery v :: Maybe Bool of- Just True -> True- _ -> False+switchQuery :: (HasDesc proxy, MonadIO actM, KnownSymbol k, NotMember k prms)+ => proxy k -> ApiaryT exts (k := Bool ': prms) actM m () -> ApiaryT exts prms actM m ()+switchQuery k = focus (DocQuery (T.pack $ symbolVal k) (StrategyRep "switch") NoValue (queryDesc k)) $ do+ qs <- getQueryParams+ (ps,fs) <- getRequestBody+ let n = maybe False id . fmap (maybe True id) . lookup (SC.pack $ symbolVal k) $ reqParams (Proxy :: Proxy Bool) qs ps fs+ insert k n <$> getParams -------------------------------------------------------------------------------- --- | check whether to exists specified header or not. since 0.6.0.0.-hasHeader :: Monad actM => HT.HeaderName -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-hasHeader n = header' Strategy.pCheck ((n ==) . fst) . Just $- toHtml (show n) <> " header requred"+-- | filter by header and get first. since 0.6.0.0.+header :: (KnownSymbol k, Monad actM, NotMember k prms)+ => proxy k -> ApiaryT exts (k := SC.ByteString ': prms) actM m () -> ApiaryT exts prms actM m ()+header k = focus' (DocPrecondition $ "has header: " <> toHtml (symbolVal k)) Nothing id $ do+ n <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . requestHeaders =<< getRequest+ insert k n <$> getParams -- | check whether to exists specified valued header or not. since 0.6.0.0.-eqHeader :: Monad actM- => HT.HeaderName - -> S.ByteString -- ^ header value- -> ApiaryT exts prms actM m ()- -> ApiaryT exts prms actM m ()-eqHeader k v = header' Strategy.pCheck (\(k',v') -> k == k' && v == v') . Just $- mconcat [toHtml $ show k, " header == ", toHtml $ show v]+eqHeader :: (KnownSymbol k, Monad actM)+ => proxy k -> SC.ByteString -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+eqHeader k v = focus' (DocPrecondition $ "header: " <> toHtml (symbolVal k) <> " = " <> toHtml (show v)) Nothing id $ do+ v' <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . requestHeaders =<< getRequest+ if v == v' then getParams else mzero --- | filter by header and get first. since 0.6.0.0.-header :: Monad actM => HT.HeaderName- -> ApiaryT exts (S.ByteString ': prms) actM m () -> ApiaryT exts prms actM m ()-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.-headers :: Monad actM => HT.HeaderName- -> ApiaryT exts ([S.ByteString] ': prms) actM m () -> ApiaryT exts prms actM m ()-headers n = header' (Strategy.pLimitSome 100) ((n ==) . fst) . Just $- toHtml (show n) <> " header requred"---- | low level header filter. since 0.6.0.0.-header' :: (Strategy.Strategy w, Monad actM)- => (forall x. Proxy x -> w x)- -> (HT.Header -> Bool)- -> Maybe Html- -> ApiaryT exts (Strategy.SNext w prms S.ByteString) actM m ()- -> ApiaryT exts prms actM m ()-header' pf kf d = function pc $ \l r ->- Strategy.readStrategy Just kf (pf pByteString) (requestHeaders r) l- where- pc = maybe id DocPrecondition d- -- | require Accept header and set response Content-Type. since 0.16.0. accept :: Monad actM => ContentType -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-accept ect = focus (DocPrecondition $ "Accept: " <> toHtml (T.decodeUtf8 ect)) $ \c ->+accept ect = focus (DocPrecondition $ "Accept: " <> toHtml (T.decodeUtf8 ect)) $ (lookup "Accept" . requestHeaders <$> getRequest) >>= \case Nothing -> mzero Just ac -> if parseContentType ect `elem` map (parseContentType . SC.dropWhile (== ' ')) (SC.split ',' ac)- then contentType ect >> return c+ then contentType ect >> getParams else mzero
src/Control/Monad/Apiary/Filter/Internal.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} module Control.Monad.Apiary.Filter.Internal ( function, function', function_, focus+ , Doc(..) ) where import Network.Wai@@ -11,21 +13,21 @@ import Control.Monad.Apiary.Internal import Control.Monad.Apiary.Action -import Data.Apiary.SList-import Data.Apiary.Document+import Data.Apiary.Dict+import Data.Apiary.Document.Internal -- | low level filter function. function :: Monad actM => (Doc -> Doc)- -> (SList prms -> Request -> Maybe (SList prms'))+ -> (Dict prms -> Request -> Maybe (Dict prms')) -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m ()-function d f = focus d $ \c -> getRequest >>= \r -> case f c r of+function d f = focus d $ getParams >>= \p -> getRequest >>= \r -> case f p r of Nothing -> mzero Just c' -> return c' -- | filter and append argument.-function' :: Monad actM => (Doc -> Doc) -> (Request -> Maybe prm)- -> ApiaryT exts (prm ': prms) actM m () -> ApiaryT exts prms actM m ()-function' d f = function d $ \c r -> (::: c) `fmap` f r+function' :: (Monad actM, NotMember key prms) => (Doc -> Doc) -> (Request -> Maybe (proxy key, prm))+ -> ApiaryT exts (key := prm ': prms) actM m () -> ApiaryT exts prms actM m ()+function' d f = function d $ \c r -> f r >>= \(k, p) -> return $ insert k p c -- | filter only(not modify arguments). function_ :: Monad actM => (Doc -> Doc) -> (Request -> Bool)
src/Control/Monad/Apiary/Filter/Internal/Capture.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DataKinds #-}@@ -17,32 +18,48 @@ import Control.Monad import Control.Monad.Apiary.Action.Internal import Control.Monad.Apiary.Internal+import Control.Monad.Apiary.Filter.Internal +import Data.Apiary.Compat import Data.Apiary.Param-import Data.Apiary.SList-import Data.Apiary.Document+import Data.Apiary.Dict import qualified Data.Text as T import Text.Blaze.Html -- | check first path and drill down. since 0.11.0. path :: Monad actM => T.Text -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-path p = focus' (DocPath p) Nothing (Exact p:) return+path p = focus' (DocPath p) Nothing (Exact p:) getParams -- | check consumed paths. since 0.11.1. endPath :: (Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-endPath = focus' id Nothing (EndPath:) return+endPath = focus' id Nothing (EndPath:) getParams -- | get first path and drill down. since 0.11.0.-fetch :: (Path p, Monad actM) => proxy p -> Maybe Html- -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m ()-fetch p h = focus' (DocFetch (pathRep p) h) Nothing (FetchPath:) $ \l -> liftM actionFetches getState >>= \case+fetch' :: (NotMember k prms, KnownSymbol k, Path p, Monad actM) => proxy k -> proxy' p -> Maybe Html+ -> ApiaryT exts (k := p ': prms) actM m () -> ApiaryT exts prms actM m ()+fetch' k p h = focus' (DocFetch (T.pack $ symbolVal k) (pathRep p) h) Nothing (FetchPath:) $ liftM actionFetches getState >>= \case [] -> mzero f:fs -> case readPathAs p f of- Just r -> (r ::: l) <$ modifyState (\s -> s {actionFetches = fs})+ Just r -> do+ modifyState (\s -> s {actionFetches = fs})+ insert k r <$> getParams Nothing -> mzero -restPath :: (Monad m, Monad actM) => ApiaryT exts ([T.Text] ': prms) actM m () -> ApiaryT exts prms actM m ()-restPath = focus' id Nothing (RestPath:) $ \l -> liftM actionFetches getState >>= \case- [] -> return $ [] ::: l- fs -> fs ::: l <$ modifyState (\s -> s {actionFetches = []})++fetch :: forall proxy k p exts prms actM m. (NotMember k prms, KnownSymbol k, Path p, Monad actM)+ => proxy (k := p) -> Maybe Html+ -> ApiaryT exts (k := p ': prms) actM m () -> ApiaryT exts prms actM m ()+fetch _ h = fetch' k p h+ where+ k = Proxy :: Proxy k+ p = Proxy :: Proxy p++anyPath :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+anyPath = focus' DocAny Nothing (RestPath:) getParams++restPath :: (NotMember k prms, KnownSymbol k, Monad m, Monad actM)+ => proxy k -> Maybe Html -> ApiaryT exts (k := [T.Text] ': prms) actM m () -> ApiaryT exts prms actM m ()+restPath k h = focus' (DocRest (T.pack $ symbolVal k) h) Nothing (RestPath:) $ getParams >>= \l -> liftM actionFetches getState >>= \case+ [] -> return $ insert k [] l+ fs -> insert k fs l <$ modifyState (\s -> s {actionFetches = []})
src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds #-} module Control.Monad.Apiary.Filter.Internal.Capture.TH where +import Control.Arrow+import Control.Applicative+ import Language.Haskell.TH import Language.Haskell.TH.Quote @@ -11,7 +15,8 @@ import qualified Data.Text as T import Data.String-import Data.Proxy+import Data.List+import Data.Apiary.Compat preCap :: String -> [String] preCap "" = []@@ -22,46 +27,56 @@ splitPath :: String -> [String] splitPath = map T.unpack . T.splitOn "/" . T.pack -data Lookup = N Name | S String | None--description :: String -> Q (String, Lookup)+-- S h -> [|Just $(stringE h)|]+-- N n -> [|Just $(varE n)|]+description :: String -> Q (String, ExpQ) description s = case break (`elem` "([") s of- (t, []) -> return (t, None)+ (t, []) -> return (t, [|Nothing|]) (t, st) -> case break (`elem` ")]") st of (_:'$':b, ")") -> do reportWarning "DEPRECATED () description. use []." v <- lookupValueName b- maybe (fail $ b ++ " not found.") (return . (t,) . N) v+ maybe (fail $ b ++ " not found.") (\n -> return (t, [|Just $(varE n)|])) v (_:b, ")") -> do reportWarning "DEPRECATED () description. use []."- return (t, S b)+ return (t, [|Just $(stringE b)|]) (_:'$':b, "]") -> lookupValueName b >>=- maybe (fail $ b ++ " not found.") (return . (t,) . N)- (_:b, "]") -> return (t, S b)+ maybe (fail $ b ++ " not found.") (\n -> return (t, [|Just $(varE n)|]))+ (_:b, "]") -> return (t, [|Just $(stringE b)|]) (_, _) -> fail "capture: syntax error." mkCap :: [String] -> ExpQ mkCap [] = [|Capture.endPath|]-mkCap ((':':tyStr):as) = do- (t, mbd) <- description tyStr- ty <- lookupTypeName t >>= maybe (fail $ t ++ " not found.") return- let d = case mbd of- None -> [|Nothing|]- S h -> [|Just $(stringE h)|]- N n -> [|Just $(varE n)|]- [|Capture.fetch (Proxy :: Proxy $(conT ty)) $d . $(mkCap as)|]-mkCap ("**":as) = [|Capture.restPath . $(mkCap as) |]-mkCap (eq:as) = [|(Capture.path (fromString $(stringE eq))) . $(mkCap as) |]+mkCap (('*':'*':[]):as) = [|Capture.anyPath . $(mkCap as) |]+mkCap (('*':'*':tS):as) = do+ (k, d) <- description tS+ [|Capture.restPath (SProxy :: SProxy $(litT $ strTyLit k)) $d . $(mkCap as) |]+mkCap (str:as)+ | "::" `isInfixOf` fst (break (`elem` "([") str) = do+ (key, d) <- first T.pack <$> description str+ let v = T.unpack . T.strip . fst $ T.breakOn "::" key+ t = T.unpack . T.strip . snd $ T.breakOnEnd "::" key+ ty <- lookupTypeName t >>= maybe (fail $ t ++ " not found.") return+ [|(Capture.fetch' (SProxy :: SProxy $(litT $ strTyLit v)) (Proxy :: Proxy $(conT ty)) $d) . $(mkCap as)|] + | otherwise = [|(Capture.path (fromString $(stringE str))) . $(mkCap as) |]+ -- | capture QuasiQuoter. since 0.1.0.0. -- -- example: -- -- @ -- [capture|\/path|] -- first path == "path"--- [capture|\/int\/:Int|] -- first path == "int" && get 2nd path as Int.--- [capture|\/:Int\/:Double|] -- get first path as Int and get 2nd path as Double.--- [capture|/**|] -- feed greedy and get all path as [Text] (since 0.17.0). +-- [capture|\/int\/foo::Int|] -- first path == "int" && get 2nd path as Int.+-- [capture|\/bar::Int\/baz::Double|] -- get first path as Int and get 2nd path as Double.+-- [capture|/**baz|] -- feed greedy and get all path as [Text] (since 0.17.0). +-- @+--+-- this QQ can convert pure function easily.+--+-- @+-- [capture|/foo/foo::Int|] == path "path" . fetch (Proxy :: Proxy ("foo" := Int)) . endPath+-- [capture|/bar/bar::Int/**rest|] == path "path" . fetch (Proxy :: Proxy ("foo" := Int)) . restPath (Proxy :: Proxy "rest") -- @ -- capture :: QuasiQuoter
− src/Control/Monad/Apiary/Filter/Internal/Strategy.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE CPP #-}--module Control.Monad.Apiary.Filter.Internal.Strategy where--import Data.Maybe-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)- -> ((k,v) -> Bool)- -> w a- -> [(k, v)]- -> SList as - -> Maybe (SList (SNext w as a))- strategyRep :: forall a. w a -> StrategyRep--getQuery :: (v -> Maybe a) -> w a -> ((k,v) -> Bool) -> [(k, v)] -> [Maybe a]-getQuery readf _ kf = map readf . map snd . filter kf---- | get first matched key( [0,) params to Type.). since 0.5.0.0.-data Option a = Option deriving Typeable-instance Strategy Option where- type SNext Option as a = Maybe a ': as- readStrategy rf k p q l =- let rs = getQuery rf p k q- in if any isNothing rs- then Nothing- else Just . (::: l) $ case catMaybes rs of- a:_ -> Just a- [] -> Nothing- strategyRep _ = StrategyRep "optional"--data Optional a = Optional T.Text a deriving Typeable-instance Strategy Optional where- type SNext Optional as a = a ': as- readStrategy rf k p@(Optional _ def) q l =- let rs = getQuery rf p k q- in if any isNothing rs- then Nothing- else Just . (::: l) $ case catMaybes rs of- a:_ -> a- [] -> def- strategyRep (Optional tr _) = StrategyRep $- "default:" `T.append` tr---- | get first matched key ( [1,) params to Maybe Type.) since 0.5.0.0.-data First a = First deriving Typeable-instance Strategy First where- type SNext First as a = a ': as- readStrategy rf k p q l =- case getQuery rf p k q of- Just a:_ -> Just $ a ::: l- _ -> Nothing- strategyRep _ = StrategyRep "first"---- | get key ( [1,1] param to Type.) since 0.5.0.0.-data One a = One deriving Typeable-instance Strategy One where- type SNext One as a = a ': as- readStrategy rf k p q l =- case getQuery rf p k q of- [Just a] -> Just $ a ::: l- _ -> Nothing- strategyRep _ = StrategyRep "one"---- | get parameters ( [0,) params to [Type] ) since 0.5.0.0.-data Many a = Many deriving Typeable-instance Strategy Many where- type SNext Many as a = [a] ': as- readStrategy rf k p q l =- let rs = getQuery rf p k q- in if any isNothing rs- then Nothing- else Just $ (catMaybes rs) ::: l- strategyRep _ = StrategyRep "many"---- | get parameters ( [1,) params to [Type] ) since 0.5.0.0.-data Some a = Some deriving Typeable-instance Strategy Some where- type SNext Some as a = [a] ': as- 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- as -> Just $ as ::: l- strategyRep _ = StrategyRep "some"---- | get parameters with upper limit ( [1,n] to [Type]) since 0.6.0.0.-data LimitSome a = LimitSome {-# UNPACK #-} !Int deriving Typeable-instance Strategy LimitSome where- type SNext LimitSome as a = [a] ': as- readStrategy rf k p@(LimitSome lim) q l =- let rs = take lim $ getQuery rf p k q- in if any isNothing rs- then Nothing- else case catMaybes rs of- [] -> Nothing- as -> Just $ as ::: l- strategyRep (LimitSome lim) = StrategyRep . T.pack $ "less then " ++ show lim---- | type check ( [0,) params to No argument ) since 0.5.0.0.-data Check a = Check deriving Typeable-instance Strategy Check where- type SNext Check as a = as- 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- _ -> Just l- strategyRep _ = StrategyRep "check"---- | construct Option proxy. since 0.5.1.0.-pOption :: proxy a -> Option a-pOption _ = Option---- | construct Optional proxy. since 0.16.0.-pOptional :: Show a => a -> Optional a-pOptional def = Optional (T.pack $ show def) def---- | construct First proxy. since 0.5.1.0.-pFirst :: proxy a -> First a-pFirst _ = First---- | construct One proxy. since 0.5.1.0.-pOne :: proxy a -> One a-pOne _ = One---- | construct Many proxy. since 0.5.1.0.-pMany :: proxy a -> Many a-pMany _ = Many---- | construct Some proxy. since 0.5.1.0.-pSome :: proxy a -> Some a-pSome _ = Some---- | construct LimitSome proxy. since 0.16.0.-pLimitSome :: Int -> proxy a -> LimitSome a-pLimitSome lim _ = LimitSome lim---- | construct Check proxy. since 0.5.1.0.-pCheck :: proxy a -> Check a-pCheck _ = Check
src/Control/Monad/Apiary/Internal.hs view
@@ -26,10 +26,10 @@ import Control.Monad.Apiary.Action.Internal import Data.List-import Data.Apiary.SList+import qualified Data.Apiary.Dict as D import Data.Apiary.Extension import Data.Apiary.Extension.Internal-import Data.Apiary.Document+import Data.Apiary.Document.Internal import Data.Monoid hiding (All) import Text.Blaze.Html import qualified Data.Text as T@@ -45,8 +45,8 @@ } data PathMethod exts actM = PathMethod- { methodMap :: H.HashMap S.ByteString (ActionT exts actM ())- , anyMethod :: Maybe (ActionT exts actM ())+ { methodMap :: H.HashMap S.ByteString (ActionT' exts actM ())+ , anyMethod :: Maybe (ActionT' exts actM ()) } emptyRouter :: Router exts actM@@ -56,7 +56,7 @@ emptyPathMethod = PathMethod H.empty Nothing insertRouter :: Monad actM => [T.Text] -> Maybe S.ByteString -> [PathElem]- -> ActionT exts actM () -> Router exts actM -> Router exts actM+ -> ActionT' exts actM () -> Router exts actM -> Router exts actM insertRouter rootPat mbMethod paths act = loop paths where loop [EndPath] (Router cln cap anp pm) =@@ -86,7 +86,7 @@ | RestPath data ApiaryEnv exts prms actM = ApiaryEnv- { envFilter :: ActionT exts actM (SList prms)+ { envFilter :: ActionT' exts actM (D.Dict prms) , envMethod :: Maybe Method , envPath :: [PathElem] -> [PathElem] , envConfig :: ApiaryConfig@@ -95,7 +95,7 @@ } initialEnv :: Monad actM => ApiaryConfig -> Extensions exts -> ApiaryEnv exts '[] actM-initialEnv conf = ApiaryEnv (return SNil) Nothing id conf id+initialEnv conf = ApiaryEnv (return D.empty) Nothing id conf id data ApiaryWriter exts actM = ApiaryWriter { writerRouter :: Router exts actM -> Router exts actM@@ -108,7 +108,7 @@ ApiaryWriter ra da am `mappend` ApiaryWriter rb db bm = ApiaryWriter (ra . rb) (da . db) (am . bm) --- | most generic Apiary monad. since 0.8.0.0.+-- | Apiary monad. since 0.8.0.0. newtype ApiaryT exts prms actM m a = ApiaryT { unApiaryT :: forall b. ApiaryEnv exts prms actM -> (a -> ApiaryWriter exts actM -> m b)@@ -120,8 +120,8 @@ -> ApiaryT exts prms actM m a apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a, w) -> cont a w -routerToAction :: Monad actM => Router exts actM -> ActionT exts actM ()-routerToAction router = getRequest >>= go+routerToAction :: Monad actM => Router exts actM -> ActionT' exts actM ()+routerToAction router = getRequest' >>= go where go req = loop id router (pathInfo req) where@@ -132,7 +132,7 @@ in maybe a (`mplus` a) $ H.lookup method mm loop fch (Router _ _ anp pm) [] = do- modifyState (\s -> s { actionFetches = fch [] } )+ modifyState' (\s -> s { actionFetches = fch [] } ) pmAction (maybe mzero (pmAction mzero) anp) pm loop fch (Router c mbcp anp _) (p:ps) = case mbcp of@@ -140,39 +140,42 @@ Just cp -> cld $ loop (fch . (p:)) cp ps `mplus` ana where ana = do- modifyState (\s -> s {actionFetches = fch $ p:ps} ) + modifyState' (\s -> s {actionFetches = fch $ p:ps} ) maybe mzero (pmAction mzero) anp cld nxt = case H.lookup p c of Nothing -> nxt Just cd -> loop fch cd ps `mplus` nxt -type EApplication e m = Extensions e -> m Application--runApiaryT :: (Monad actM, Monad m)- => (forall b. actM b -> IO b)- -> ApiaryConfig- -> ApiaryT exts '[] actM m ()- -> EApplication exts m-runApiaryT runAct conf m exts = do+-- | run Apiary monad.+runApiaryTWith :: (Monad actM, Monad m)+ => (forall b. actM b -> IO b)+ -> (Application -> m a)+ -> Initializer m '[] exts+ -> ApiaryConfig+ -> ApiaryT exts '[] actM m ()+ -> m a+runApiaryTWith runAct run (Initializer ir) conf m = ir NoExtension $ \exts -> do wtr <- unApiaryT m (initialEnv conf exts) (\_ w -> return w) let doc = docsToDocuments $ writerDoc wtr [] rtr = writerRouter wtr emptyRouter mw = writerMw wtr- return $! mw $ execActionT conf exts doc (hoistActionT runAct $ routerToAction rtr)--runApiary :: Monad m- => ApiaryConfig- -> ApiaryT exts '[] IO m ()- -> EApplication exts m-runApiary = runApiaryT id+ app = mw $ execActionT' conf exts doc (hoistActionT' runAct $ routerToAction rtr)+ run app -server :: Monad m => (Application -> m a) -> EApplication '[] m -> m a-server = serverWith noExtension+runApiaryWith :: Monad m+ => (Application -> m a)+ -> Initializer m '[] exts+ -> ApiaryConfig+ -> ApiaryT exts '[] IO m ()+ -> m a+runApiaryWith = runApiaryTWith id -serverWith :: Monad m => Initializer m '[] exts - -> (Application -> m a) -> (EApplication exts m) -> m a-serverWith (Initializer ir) run em = ir NoExtension $ \exts ->- em exts >>= run+runApiary :: Monad m+ => (Application -> m a)+ -> ApiaryConfig+ -> ApiaryT '[] '[] IO m ()+ -> m a+runApiary run = runApiaryWith run noExtension -------------------------------------------------------------------------------- @@ -222,9 +225,11 @@ getApiaryEnv :: Monad actM => ApiaryT exts prms actM m (ApiaryEnv exts prms actM) getApiaryEnv = ApiaryT $ \env cont -> cont env mempty +-- | get Apiary extension. apiaryExt :: (Has e exts, Monad actM) => proxy e -> ApiaryT exts prms actM m e apiaryExt p = getExtension p . envExts <$> getApiaryEnv +-- | get Apiary configuration. apiaryConfig :: Monad actM => ApiaryT exts prms actM m ApiaryConfig apiaryConfig = liftM envConfig getApiaryEnv @@ -234,7 +239,7 @@ -- | filter by action. since 0.6.1.0. focus :: Monad actM => (Doc -> Doc)- -> (SList prms -> ActionT exts actM (SList prms'))+ -> ActionT exts prms actM (D.Dict prms') -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m () focus d g m = focus' d Nothing id g m @@ -242,32 +247,29 @@ => (Doc -> Doc) -> Maybe Method -> ([PathElem] -> [PathElem])- -> (SList prms -> ActionT exts actM (SList prms'))+ -> ActionT exts prms actM (D.Dict prms') -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m () focus' d meth pth g m = ApiaryT $ \env cont -> unApiaryT m env - { envFilter = envFilter env >>= g + { envFilter = envFilter env >>= flip applyDict g , envMethod = maybe (envMethod env) Just meth , envPath = envPath env . pth , envDoc = envDoc env . d } cont --- | splice ActionT ApiaryT.-action :: Monad actM => Fn prms (ActionT exts actM ()) -> ApiaryT exts prms actM m ()-action = action' . apply---- | like action. but not apply arguments. since 0.8.0.0.-action' :: Monad actM => (SList prms -> ActionT exts actM ()) -> ApiaryT exts prms actM m ()-action' a = do+-- | splice ActionT to ApiaryT.+action :: Monad actM => ActionT exts prms actM () -> ApiaryT exts prms actM m ()+action a = do env <- getApiaryEnv addRoute $ ApiaryWriter (insertRouter (rootPattern $ envConfig env) (renderMethod <$> envMethod env) (envPath env [])- (envFilter env >>= \prms -> a prms))+ (envFilter env >>= flip applyDict a)) (envDoc env Action:) id +-- | add middleware. middleware :: Monad actM => Middleware -> ApiaryT exts prms actM m () middleware mw = addRoute (ApiaryWriter id id mw) @@ -294,13 +296,6 @@ precondition :: Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () precondition = insDoc . DocPrecondition +-- | ignore next document. noDoc :: ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () noDoc = insDoc DocDropNext------------------------------------------------------------------------------------{-# DEPRECATED actionWithPreAction "use action'" #-}--- | execute action before main action. since 0.4.2.0-actionWithPreAction :: Monad actM => (SList xs -> ActionT exts actM a)- -> Fn xs (ActionT exts actM ()) -> ApiaryT exts xs actM m ()-actionWithPreAction pa a = action' $ \prms -> pa prms >> apply a prms
+ src/Data/Apiary/Compat.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}++-- | compatibility module for ghc-7.8 & ghc-7.6.+module Data.Apiary.Compat+ ( -- * type level string literal+ Symbol, KnownSymbol, symbolVal+ , SProxy(..)++ -- * Data.Typeables+ , module Data.Typeable+#if !MIN_VERSION_base(4,7,0)+ , typeRep+ , Proxy(..)+#endif+ ) where++import GHC.TypeLits+import Data.Typeable+#if !MIN_VERSION_base(4,7,0)++typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep+typeRep _ = typeOf (undefined :: a)+{-# INLINE typeRep #-}++type KnownSymbol (n :: Symbol) = SingRep n String++symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String+symbolVal _ = fromSing (sing :: Sing n)++data Proxy a = Proxy+#endif++-- | Symbol Proxy for ghc-7.6.+data SProxy (a :: Symbol) = SProxy
+ src/Data/Apiary/Dict.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | type sefe dictionaly.+module Data.Apiary.Dict+ ( Dict+ , empty+ , insert+ , Member(get)+ , key++ -- * types+ , Elem((:=))+ , NotMember+ , Member'+ , Members+ ) where++import Data.Apiary.Compat++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import GHC.Exts++-- | (kind) Dict element.+data Elem = forall a. Symbol := a++data Dict (ks :: [Elem]) where+ Empty :: Dict '[]+ Insert :: proxy (k :: Symbol) -> v -> Dict ks -> Dict (k := v ': ks)+++class Member (k :: Symbol) (v :: *) (kvs :: [Elem]) | k kvs -> v where++ -- | get value of key.+ --+ -- > ghci> get (SProxy :: SProxy "bar") $ insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+ -- > 0.5+ --+ -- > ghci> get (SProxy :: SProxy "foo") $ insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+ -- > 12+ --+ -- ghc raise compile error when key is not exists.+ --+ -- > ghci> get (SProxy :: SProxy "baz") $ insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+ -- > <interactive>:15:1:+ -- > No instance for (Member "baz" a0 '[]) arising from a use of ‘it’+ -- > In the first argument of ‘print’, namely ‘it’+ -- > In a stmt of an interactive GHCi command: print it++ get :: proxy k -> Dict kvs -> v++instance Member k v (k := v ': kvs) where+ get _ (Insert _ v _) = v++instance Member k v kvs => Member k v (k' := v' ': kvs) where+ get p (Insert _ _ d) = get p d++-- | type family version Member for NotMember constraint.+#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 708+type family Member' (k::Symbol) (kvs :: [Elem]) :: Bool where+ Member' k '[] = False+ Member' k (k := v ': kvs) = True+ Member' k' (k := v ': kvs) = Member' k' kvs+#else+type family Member' (k::Symbol) (kvs :: [Elem]) :: Bool+type instance Member' k kvs = False+#endif++type NotMember k kvs = Member' k kvs ~ False++-- | type family to constraint multi kvs.+--+-- > Members ["foo" := Int, "bar" := Double] prms == (Member "foo" Int prms, Member "bar" Double prms)+--+type family Members (kvs :: [Elem]) (prms :: [Elem]) :: Constraint+type instance Members '[] prms = ()+type instance Members (k := v ': kvs) prms = (Member k v prms, Members kvs prms)++-- | empty Dict.+empty :: Dict '[]+empty = Empty++-- | insert element.+-- +-- > ghci> :t insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > :: Dict '["foo" ':= Int]+-- +-- > ghci> :t insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > :: Dict '["bar" ':= Double, "foo" ':= Int]+--+-- ghc raise compile error when insert duplicated key(> ghc-7.8 only).+--+-- > ghci> :t insert (SProxy :: SProxy "foo") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > +-- > <interactive>:1:1:+-- > Couldn't match type ‘'True’ with ‘'False’+-- > Expected type: 'False+-- > Actual type: Member' "foo" '["foo" ':= Int]+-- > In the expression: insert (SProxy :: SProxy "foo") (0.5 :: Double)+-- > In the expression:+-- > insert (SProxy :: SProxy "foo") (0.5 :: Double)+-- > $ insert (SProxy :: SProxy "foo") (12 :: Int) empty++insert :: NotMember k kvs => proxy k -> v -> Dict kvs -> Dict (k := v ': kvs)+insert = Insert++-- | construct string literal proxy.+--+-- prop> [key|foo|] == (SProxy :: SProxy "foo")+--+key :: QuasiQuoter+key = QuasiQuoter+ { quoteExp = \s -> [| SProxy :: SProxy $(litT $ strTyLit s) |]+ , quotePat = error "key qq only exp or type."+ , quoteType = \s -> [t| SProxy $(litT $ strTyLit s) |]+ , quoteDec = error "key qq only exp or type."+ }
src/Data/Apiary/Document.hs view
@@ -1,136 +1,9 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoMonomorphismRestriction #-}--module Data.Apiary.Document where--import Control.Applicative--import Data.Typeable-import Data.Maybe-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)--data Doc- = DocPath T.Text Doc- | DocRoot Doc- | DocFetch TypeRep (Maybe Html) Doc- | DocDropNext Doc-- | DocMethod Method Doc- | DocQuery S.ByteString StrategyRep QueryRep (Maybe Html) Doc- | DocPrecondition Html Doc- | DocGroup T.Text Doc- | Document T.Text Doc- | Action------------------------------------------------------------------------------------data Route- = Path T.Text Route- | Fetch TypeRep (Maybe Html) Route- | End--instance Eq Route where- Path a d == Path b d' = a == b && d == d'- Fetch a _ d == Fetch b _ d' = a == b && d == d'- End == End = True- _ == _ = False--data Documents = Documents- { noGroup :: [PathDoc]- , groups :: [(T.Text, [PathDoc])]- }--data PathDoc = PathDoc- { path :: Route- , methods :: [(Method, [MethodDoc])]- }--data QueryDoc = QueryDoc- { queryName :: S.ByteString- , queryStrategy :: StrategyRep- , queryRep :: QueryRep- , queryDocument :: (Maybe Html)- }--data MethodDoc = MethodDoc- { queries :: [QueryDoc]- , preconditions :: [Html]- , document :: T.Text- }------------------------------------------------------------------------------------docToDocument :: Doc -> Maybe (Maybe T.Text, PathDoc)-docToDocument = \case- (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 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)- where- same = (==) `on` path- merge pds' = PathDoc (path pd) (mergeMethods $ methods pd ++ concatMap methods pds')--mergeMethods :: [(Method, [MethodDoc])] -> [(Method, [MethodDoc])]-mergeMethods [] = []-mergeMethods (m:ms) = merge (filter (same m) ms) : mergeMethods (filter (not . same m) ms)- where- same = (==) `on` fst- merge ms' = (fst m, snd m ++ concatMap snd ms')---docsToDocuments :: [Doc] -> Documents-docsToDocuments doc =- let gds = mapMaybe docToDocument doc- ngs = mergePathDoc . map snd $ filter ((Nothing ==) . fst) gds- gs = map upGroup . groupBy ((==) `on` fst) $ mapMaybe trav gds- in Documents ngs gs- where- upGroup ((g,d):ig) = (g, mergePathDoc $ d : map snd ig)- upGroup [] = error "docsToDocuments: unknown error."-- trav (Nothing, _) = Nothing- trav (Just a, b) = Just (a, b)-+module Data.Apiary.Document+ ( Documents(..)+ , Route(..)+ , PathDoc(..)+ , MethodDoc(..)+ , QueryDoc(..)+ ) where +import Data.Apiary.Document.Internal
src/Data/Apiary/Document/Html.hs view
@@ -2,11 +2,18 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -module Data.Apiary.Document.Html where+module Data.Apiary.Document.Html+ ( defaultDocumentToHtml+ -- * config+ , DefaultDocumentConfig(..)+ -- * other functions+ , rpHtml+ ) where import Language.Haskell.TH -import Data.Monoid+import Data.Monoid hiding (Any)+import Data.Maybe import Data.Default.Class import Data.Apiary.Param@@ -20,24 +27,28 @@ 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 []+routeToHtml = loop "" 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+ loop e r p (Path s d) = loop (T.concat [e, "/", s]) (r <> sp <> H.span (toHtml s) ! A.class_ "path") p d+ loop e r p (Fetch k t mbh d) = + let r' = r <> sp <> rpHtml (toHtml k) (if isJust mbh then Nothing else Just . toHtml $ show t)+ p' = maybe p (\h -> p <> [H.tr $ H.td (toHtml k) <> H.td (toHtml $ show t) <> H.td h]) mbh+ in loop (T.concat [e, "/", k, "::", T.pack $ show t]) r' p' d+ loop e r p (Rest k mbh) =+ let p' = maybe p (\h -> p <> [H.tr $ H.td (toHtml k) <> H.td "[Text]" <> H.td h]) mbh+ in loop (T.concat [e, "/**", k]) (r <> sp <> (H.span "**" ! A.class_ "rest") <> (H.span (toHtml k) ! A.class_ "fetch")) p' End+ loop e r p Any =+ loop (T.concat [e, "/**"]) (r <> sp <> (H.span "**" ! A.class_ "rest")) p End+ 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" $ "name" , H.th ! A.class_ "col-sm-1 com-md-1" $ "type" , H.th "description" ]) <> mconcat p@@ -107,7 +118,7 @@ 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 p) , H.td (toHtml $ strategyInfo s) , H.td (htmlQR q) , H.td $ maybe noDesc id t@@ -179,5 +190,5 @@ ] -- | 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"+rpHtml :: Html -> Maybe Html -> Html+rpHtml k mbt = (H.span k ! A.class_ "fetch") <> maybe mempty (\t -> H.span (" :: " <> t) ! A.class_ "type") mbt
+ src/Data/Apiary/Document/Internal.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Data.Apiary.Document.Internal where++import Control.Applicative++import Data.Typeable+import Data.Maybe+import Data.List+import Data.Function++import Data.Apiary.Param+import Data.Apiary.Method++import Text.Blaze.Html+import qualified Data.Text as T++data Doc+ = DocPath T.Text Doc+ | DocRoot Doc+ | DocFetch T.Text TypeRep (Maybe Html) Doc+ | DocRest T.Text (Maybe Html) Doc+ | DocAny Doc+ | DocDropNext Doc++ | DocMethod Method Doc+ | DocQuery T.Text StrategyRep QueryRep (Maybe Html) Doc+ | DocPrecondition Html Doc+ | DocGroup T.Text Doc+ | Document T.Text Doc+ | Action++--------------------------------------------------------------------------------++data Route+ = Path T.Text Route+ | Fetch T.Text TypeRep (Maybe Html) Route+ | Rest T.Text (Maybe Html) -- ^ \*\* with name+ | Any -- ^ \*\* without name+ | End++instance Eq Route where+ Path a d == Path b d' = a == b && d == d'+ Fetch k a _ d == Fetch l b _ d' = k == l && a == b && d == d'+ Rest k _ == Rest l _ = k == l+ Any == Any = True+ End == End = True+ _ == _ = False++data Documents = Documents+ { noGroup :: [PathDoc]+ , groups :: [(T.Text, [PathDoc])]+ }++data PathDoc = PathDoc+ { path :: Route+ , methods :: [(Method, [MethodDoc])]+ }++-- | query parameters document+data QueryDoc = QueryDoc+ { queryName :: T.Text+ , queryStrategy :: StrategyRep+ , queryRep :: QueryRep+ , queryDocument :: (Maybe Html)+ }++data MethodDoc = MethodDoc+ { queries :: [QueryDoc]+ , preconditions :: [Html]+ , document :: T.Text+ }++--------------------------------------------------------------------------------++docToDocument :: Doc -> Maybe (Maybe T.Text, PathDoc)+docToDocument = \case+ (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 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 k t h d) = loop (ph . Fetch k t h) mh qs pc doc d+ loop ph mh qs pc doc (DocRest k h d) = loop (ph . const (Rest k h)) mh qs pc doc d+ loop ph mh qs pc doc (DocAny d) = loop (ph . const Any) 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 (DocRest _ _ d) = d+ dropNext (DocAny 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)+ where+ same = (==) `on` path+ merge pds' = PathDoc (path pd) (mergeMethods $ methods pd ++ concatMap methods pds')++mergeMethods :: [(Method, [MethodDoc])] -> [(Method, [MethodDoc])]+mergeMethods [] = []+mergeMethods (m:ms) = merge (filter (same m) ms) : mergeMethods (filter (not . same m) ms)+ where+ same = (==) `on` fst+ merge ms' = (fst m, snd m ++ concatMap snd ms')+++docsToDocuments :: [Doc] -> Documents+docsToDocuments doc =+ let gds = mapMaybe docToDocument doc+ ngs = mergePathDoc . map snd $ filter ((Nothing ==) . fst) gds+ gs = map upGroup . groupBy ((==) `on` fst) $ mapMaybe trav gds+ in Documents ngs gs+ where+ upGroup ((g,d):ig) = (g, mergePathDoc $ d : map snd ig)+ upGroup [] = error "docsToDocuments: unknown error."++ trav (Nothing, _) = Nothing+ trav (Just a, b) = Just (a, b)
src/Data/Apiary/Extension.hs view
@@ -6,9 +6,8 @@ module Data.Apiary.Extension ( Has(getExtension) , Extensions- , addExtension , noExtension- -- * create initializer+ -- * initializer constructor , Initializer, initializer , Initializer', initializer' , initializerBracket@@ -16,8 +15,6 @@ -- * combine initializer , (+>)- -- * deprecated- , preAction ) where import Data.Apiary.Extension.Internal@@ -41,10 +38,6 @@ initializerBracket' :: (forall a. (e -> m a) -> m a) -> Initializer m es (e ': es) initializerBracket' m = initializerBracket (const m)--{-# DEPRECATED preAction "DEPRECATED" #-}-preAction :: Monad m => m a -> Initializer m i i-preAction f = Initializer $ \es n -> f >> n es -- | combine two Initializer. since 0.16.0. (+>) :: Monad m => Initializer m i x -> Initializer m x o -> Initializer m i o
src/Data/Apiary/Param.hs view
@@ -13,17 +13,60 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-}--module Data.Apiary.Param where+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-} -import Network.Wai+module Data.Apiary.Param+ ( -- * route path parameter+ Path(..)+ , readPathAs+ -- * query parameter+ , Query(..)+ , QueryRep(..)+ , File(..)+ -- * request parameter+ , Param+ , ReqParam(..)+ -- * Strategy+ , Strategy(..)+ , StrategyRep(..)+ , First(..)+ , One(..)+ , Many(..)+ , Some(..)+ , Option(..)+ , Optional(..)+ -- * Proxies+ , pBool+ , pInt+ , pWord+ , pDouble+ , pText+ , pLazyText+ , pByteString+ , pLazyByteString+ , pString+ , pMaybe+ , pFile+ -- ** strategy+ , pFirst+ , pOne+ , pMany+ , pSome+ , pOption+ , pOptional+ ) where import Control.Monad+import Control.Arrow +import qualified Network.HTTP.Types as Http+ import Data.Int+import Data.Maybe import Data.Word-import Data.Proxy-import Data.Apiary.Proxy+import Data.Apiary.Compat+import Data.Apiary.Dict import Data.String(IsString) import Data.Time.Calendar@@ -45,6 +88,7 @@ where jsFalse = ["false", "0", "-0", "", "null", "undefined", "NaN"] +-- | readPath providing type using Proxy. readPathAs :: Path a => proxy a -> T.Text -> Maybe a readPathAs _ t = readPath t {-# INLINE readPathAs #-}@@ -61,14 +105,17 @@ } deriving (Show, Eq, Typeable) data QueryRep- = Strict TypeRep- | Nullable TypeRep- | Check+ = Strict TypeRep -- ^ require value+ | Nullable TypeRep -- ^ allow key only value+ | Check -- ^ check existance | NoValue deriving (Show, Eq) class Path a where- readPath :: T.Text -> Maybe a+ -- | read route path parameter.+ readPath :: T.Text+ -> Maybe a -- ^ Nothing is failed.+ -- | pretty type of route path parameter. pathRep :: proxy a -> TypeRep instance Path Char where@@ -121,7 +168,11 @@ -------------------------------------------------------------------------------- class Query a where- readQuery :: Maybe S.ByteString -> Maybe a+ -- | read query parameter.+ readQuery :: Maybe S.ByteString -- ^ value of query parameter. Nothing is key only parameter.+ -> Maybe a -- ^ Noting is fail.++ -- | pretty query parameter. queryRep :: proxy a -> QueryRep queryRep = Strict . qTypeRep qTypeRep :: proxy a -> TypeRep@@ -240,32 +291,12 @@ pInt :: Proxy Int pInt = Proxy-pInt8 :: Proxy Int8-pInt8 = Proxy-pInt16 :: Proxy Int16-pInt16 = Proxy-pInt32 :: Proxy Int32-pInt32 = Proxy-pInt64 :: Proxy Int64-pInt64 = Proxy-pInteger :: Proxy Integer-pInteger = Proxy pWord :: Proxy Word pWord = Proxy-pWord8 :: Proxy Word8-pWord8 = Proxy-pWord16 :: Proxy Word16-pWord16 = Proxy-pWord32 :: Proxy Word32-pWord32 = Proxy-pWord64 :: Proxy Word64-pWord64 = Proxy pDouble :: Proxy Double pDouble = Proxy-pFloat :: Proxy Float-pFloat = Proxy pText :: Proxy T.Text pText = Proxy@@ -278,9 +309,6 @@ pString :: Proxy String pString = Proxy -pVoid :: Proxy ()-pVoid = Proxy- pMaybe :: proxy a -> Proxy (Maybe a) pMaybe _ = Proxy @@ -288,7 +316,7 @@ pFile = Proxy class ReqParam a where- reqParams :: proxy a -> Request -> [Param] -> [File] -> [(S.ByteString, Maybe a)]+ reqParams :: proxy a -> Http.Query -> [Param] -> [File] -> [(S.ByteString, Maybe a)] reqParamRep :: proxy a -> QueryRep instance ReqParam File where@@ -296,6 +324,77 @@ reqParamRep _ = Strict $ typeRep pFile instance Query a => ReqParam a where- reqParams _ r p _ = map (\(k,v) -> (k, readQuery v)) (queryString r) ++- map (\(k,v) -> (k, readQuery $ Just v)) p+ reqParams _ q p _ = map (second readQuery) q +++ map (second $ readQuery . Just) p reqParamRep = queryRep++newtype StrategyRep = StrategyRep+ { strategyInfo :: T.Text }+ deriving (Show, Eq)+++class Strategy (w :: * -> *) where+ type SNext w (k::Symbol) a (prms :: [Elem]) :: [Elem]+ strategy :: (NotMember k prms, MonadPlus m) => w a -> proxy' k -> [Maybe a] -> Dict prms -> m (Dict (SNext w k a prms))+ strategyRep :: w a -> StrategyRep++data First a = First+instance Strategy First where+ type SNext First k a ps = k := a ': ps+ strategy _ k (Just a:_) d = return $ insert k a d+ strategy _ _ _ _ = mzero+ strategyRep _ = StrategyRep "first"++data One a = One+instance Strategy One where+ type SNext One k a ps = k := a ': ps+ strategy _ k [Just a] d = return $ insert k a d+ strategy _ _ _ _ = mzero+ strategyRep _ = StrategyRep "one"++data Many a = Many+instance Strategy Many where+ type SNext Many k a ps = k := [a] ': ps+ strategy _ k as d = if all isJust as then return $ insert k (catMaybes as) d else mzero+ strategyRep _ = StrategyRep "many"++data Some a = Some+instance Strategy Some where+ type SNext Some k a ps = k := [a] ': ps+ strategy _ _ [] _ = mzero+ strategy _ k as d = if all isJust as then return $ insert k (catMaybes as) d else mzero+ strategyRep _ = StrategyRep "some"++data Option a = Option+instance Strategy Option where+ type SNext Option k a ps = k := Maybe a ': ps+ strategy _ k (Just a:_) d = return $ insert k (Just a) d+ strategy _ _ (Nothing:_) _ = mzero+ strategy _ k [] d = return $ insert k Nothing d+ strategyRep _ = StrategyRep "option"++data Optional a = Optional T.Text a+instance Strategy Optional where+ type SNext Optional k a ps = k := a ': ps+ strategy _ k (Just a:_) d = return $ insert k a d+ strategy _ _ (Nothing:_) _ = mzero+ strategy (Optional _ a) k [] d = return $ insert k a d+ strategyRep (Optional a _) = StrategyRep $ "default:" `T.append` a++pFirst :: proxy a -> First a+pFirst _ = First++pOne :: proxy a -> One a+pOne _ = One++pMany :: proxy a -> Many a+pMany _ = Many++pSome :: proxy a -> Some a+pSome _ = Some++pOption :: proxy a -> Option a+pOption _ = Option++pOptional :: Show a => a -> Optional a+pOptional a = Optional (T.pack $ show a) a
− src/Data/Apiary/Proxy.hs
@@ -1,20 +0,0 @@-{-# 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
− src/Data/Apiary/SList.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}--module Data.Apiary.SList where--import GHC.Exts(Constraint)--data SList (as :: [*]) where- SNil :: SList '[]- (:::) :: a -> SList xs -> SList (a ': xs)--infixr :::--type family All (c :: * -> Constraint) (as :: [*]) :: Constraint-type instance All c '[] = ()-type instance All c (a ': as) = (c a, All c as)--deriving instance All Show as => Show (SList as)--type family Apply (as :: [*]) r-type instance Apply '[] r = r-type instance Apply (x ': xs) r = x -> Apply xs r--type Fn c a = Apply (Reverse c) a-apply :: Fn c r -> SList c -> r-apply f l = apply' f $ sReverse l--apply' :: Apply xs r -> SList xs -> r-apply' v SNil = v-apply' f (a ::: as) = apply' (f a) as--type family Rev (l :: [*]) (a :: [*]) :: [*]-type instance Rev '[] a = a-type instance Rev (x ': xs) a = Rev xs (x ': a)--type Reverse (a :: [*]) = Rev a '[]--sReverse :: SList as -> SList (Reverse as)-sReverse l = rev l SNil- where- rev :: SList as -> SList bs -> SList (Rev as bs)- rev SNil a = a- rev (x:::xs) a = rev xs (x:::a)
src/Web/Apiary.hs view
@@ -2,16 +2,17 @@ ( module Control.Monad.Apiary , module Control.Monad.Apiary.Action , module Control.Monad.Apiary.Filter+ -- | File(..), Proxies , module Data.Apiary.Param- -- | Strategy Proxies- , module Control.Monad.Apiary.Filter.Internal.Strategy+ -- | Method(..) , module Data.Apiary.Method -- | Has, Extensions, Initializer, Initializer', (+>) , module Data.Apiary.Extension- , act+ -- | key, Member, Members, NotMember, Elem((:=))+ , module Data.Apiary.Dict - -- * reexports+ -- | hiding mkStatus , module Network.HTTP.Types.Status -- | def , module Data.Default.Class@@ -25,19 +26,68 @@ , module Text.Blaze.Html ) where -import Web.Apiary.TH-import Network.Wai(FilePart(..), Application)-import Network.HTTP.Types.Status hiding (mkStatus)- import Control.Monad.Apiary+ ( ApiaryT+ , runApiaryTWith+ , runApiaryWith+ , runApiary+ , ApiaryConfig(..)+ , action+ , middleware+ , group+ , document+ , precondition+ , noDoc+ )+ import Control.Monad.Apiary.Action+ ( ActionT+ , stop+ , param+ , params+ , status+ , addHeader, setHeaders, modifyHeader+ , contentType+ , reset+ , builder+ , bytes, lazyBytes+ , text, lazyText+ , showing+ , string, char+ , file+ , redirect, redirectPermanently, redirectTemporary+ , defaultDocumentationAction+ , DefaultDocumentConfig(..)+ )+ import Control.Monad.Apiary.Filter-import Control.Monad.Apiary.Filter.Internal.Strategy (pFirst, pOne, pOption, pCheck, pMany, pSome)-import Control.Monad.IO.Class(MonadIO(..))-import Control.Monad (MonadPlus(..), msum, mfilter, guard, (>=>))+ ( method+ , http09, http10, http11+ , root, capture+ , (??)+ , (=:), (=!:), (=?:), (=?!:), (=*:), (=+:)+ , switchQuery+ , eqHeader+ , header+ , accept+ , ssl+ ) -import Data.Default.Class(def) import Data.Apiary.Param-import Data.Apiary.Extension(Has, Extensions, Initializer, Initializer', (+>))+ ( File(..)+ , pBool, pInt, pWord, pDouble+ , pText, pLazyText, pByteString, pLazyByteString, pString+ , pMaybe, pFile+ , pFirst, pOne, pMany, pSome, pOption, pOptional+ )+ import Data.Apiary.Method(Method(..))+import Data.Apiary.Extension(Has, Extensions, Initializer, Initializer', (+>))+import Data.Apiary.Dict(key, Member, Members, NotMember, Elem((:=)))++import Network.HTTP.Types.Status hiding (mkStatus)+import Data.Default.Class(def)+import Control.Monad.IO.Class(MonadIO(..))+import Control.Monad (MonadPlus(..), msum, mfilter, guard, (>=>))+import Network.Wai(FilePart(..), Application) import Text.Blaze.Html(Html)
src/Web/Apiary/Heroku.hs view
@@ -7,8 +7,12 @@ {-# LANGUAGE FlexibleContexts #-} module Web.Apiary.Heroku- ( Heroku, HerokuConfig(..)- , heroku, herokuWith+ ( Heroku+ -- * configuration+ , HerokuConfig(..)+ -- * runner+ , runHeroku, runHerokuWith, runHerokuTWith+ -- * extension functions , getHerokuEnv, getHerokuEnv' ) where @@ -22,7 +26,7 @@ import Control.Monad.Trans import Data.IORef-import Data.Proxy+import Data.Apiary.Compat import Data.Default.Class import qualified Data.HashMap.Strict as H import qualified Data.Text as T@@ -31,7 +35,6 @@ import Network.Wai import Control.Monad.Apiary import Data.Apiary.Extension-import Data.Apiary.Extension.Internal data Heroku = Heroku { herokuEnv :: IORef (Maybe (H.HashMap T.Text T.Text))@@ -42,10 +45,11 @@ { defaultPort :: Int , herokuExecutableName :: String , herokuAppName :: Maybe String+ , herokuApiaryConfig :: ApiaryConfig } instance Default HerokuConfig where- def = HerokuConfig 3000 "heroku" Nothing+ def = HerokuConfig 3000 "heroku" Nothing def initHeroku :: MonadIO m => HerokuConfig -> Initializer' m Heroku initHeroku conf = initializer' . liftIO $@@ -59,34 +63,41 @@ -- -- @ herokuWith exts run def . runApiary def $ foo @ ---herokuWith :: MonadIO m => Initializer m '[Heroku] exts- -> (Int -> Application -> m a)- -> HerokuConfig -> EApplication exts m -> m a-herokuWith ir run conf eapp = ir' NoExtension $ \exts -> do+runHerokuTWith :: (MonadIO m, Monad actM)+ => (forall b. actM b -> IO b)+ -> (Int -> Application -> m a)+ -> Initializer m '[Heroku] exts+ -> HerokuConfig+ -> ApiaryT exts '[] actM m ()+ -> m a+runHerokuTWith runAct run ir conf m = do port <- liftIO $ fmap read (getEnv "PORT") `catch` (\(_::IOError) -> return $ defaultPort conf)- app <- eapp exts- run port app- where- Initializer ir' = initHeroku conf +> ir+ runApiaryTWith runAct (run port) (initHeroku conf +> ir) (herokuApiaryConfig conf) m --- | use this function instead of server in heroku app. since 0.17.0.------ @ server (run 3000) . runApiary def $ foo @------ to------ @ heroku run def . runApiary def $ foo @+runHerokuWith :: MonadIO m+ => (Int -> Application -> m a)+ -> Initializer m '[Heroku] exts+ -> HerokuConfig+ -> ApiaryT exts '[] IO m ()+ -> m a+runHerokuWith = runHerokuTWith id++-- | use this function instead of runApiary in heroku app. since 0.18.0. -- -- this function provide: -- -- * set port by PORT environment variable. -- * getHerokuEnv function(get config from environment variable or @ heroku config @ command).-heroku :: MonadIO m => (Int -> Application -> m a)- -> HerokuConfig -> EApplication '[Heroku] m -> m a-heroku = herokuWith noExtension+runHeroku :: MonadIO m+ => (Int -> Application -> m a)+ -> HerokuConfig+ -> ApiaryT '[Heroku] '[] IO m ()+ -> m a+runHeroku run = runHerokuWith run noExtension -getHerokuEnv' :: T.Text -> Heroku -> IO (Maybe T.Text)+getHerokuEnv' :: T.Text -- ^ heroku environment variable name+ -> Heroku -> IO (Maybe T.Text) getHerokuEnv' key Heroku{..} = try (getEnv $ T.unpack key) >>= \case Right e -> return (Just $ T.pack e) Left (_::SomeException) -> readIORef herokuEnv >>= \case@@ -106,5 +117,6 @@ else Nothing <$ writeIORef herokuEnv (Just H.empty) -getHerokuEnv :: Has Heroku exts => T.Text -> Extensions exts -> IO (Maybe T.Text)+getHerokuEnv :: Has Heroku exts => T.Text -- ^ heroku environment variable name+ -> Extensions exts -> IO (Maybe T.Text) getHerokuEnv key exts = getHerokuEnv' key (getExtension Proxy exts)
− src/Web/Apiary/TH.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TemplateHaskell #-}-module Web.Apiary.TH where--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--numToCode :: Int -> ExpQ-numToCode = \case- 100 -> varE 'status100- 101 -> varE 'status101-- 200 -> varE 'status200- 201 -> varE 'status201- 202 -> varE 'status202- 203 -> varE 'status203- 204 -> varE 'status204- 205 -> varE 'status205- 206 -> varE 'status206-- 300 -> varE 'status300- 301 -> varE 'status301- 302 -> varE 'status302- 303 -> varE 'status303- 304 -> varE 'status304- 305 -> varE 'status305- 307 -> varE 'status307-- 400 -> varE 'status400- 401 -> varE 'status401- 402 -> varE 'status402- 403 -> varE 'status403- 404 -> varE 'status404- 405 -> varE 'status405- 406 -> varE 'status406- 407 -> varE 'status407- 408 -> varE 'status408- 409 -> varE 'status409- 410 -> varE 'status410- 411 -> varE 'status411- 412 -> varE 'status412- 413 -> varE 'status413- 414 -> varE 'status414- 415 -> varE 'status415- 416 -> varE 'status416- 417 -> varE 'status417- 418 -> varE 'status418-- 500 -> varE 'status500- 501 -> varE 'status501- 502 -> varE 'status502- 503 -> varE 'status503- 504 -> varE 'status504- 505 -> varE 'status505-- n -> fail $ "unknown HTTP status code:" ++ show n--{-# DEPRECATED act "no longer maintained" #-}--- | shortcut action. since 0.6.0.0.------ @--- [act|200 .html|] == [act|200 text/html|] ==--- action $ \\arguments -> do--- status 200--- contentType "text/html"--- @-act :: QuasiQuoter-act = QuasiQuoter - { quoteExp = act'- , quotePat = \_ -> fail "act QQ only Exp."- , quoteType = \_ -> fail "act QQ only Exp."- , quoteDec = \_ -> fail "act QQ only Exp."- }--parseAct :: String -> (Int, String)-parseAct s =- let (code, ct) = T.break (== ' ') . T.strip $ T.pack s- mime = case T.strip ct of- t | T.head t == '.' -> defaultMimeLookup t- | otherwise -> S.pack $ T.unpack t- in (read $ T.unpack code, S.unpack mime)--act' :: String -> ExpQ-act' s = - let (code, mime) = parseAct s- in [| \a -> action' (\l -> do - status $(numToCode code)- contentType $(stringE mime)- apply a l- )|]
static/api-documentation.min.css view
@@ -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}.no-description{color:#aaa}+.fetch{text-decoration:underline}.type .rest{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}
test/Application.hs view
@@ -52,7 +52,7 @@ -------------------------------------------------------------------------------- runApp :: ApiaryT '[] '[] IO Identity () -> Application-runApp = runIdentity . server return . runApiary def+runApp = runIdentity . runApiary return def -------------------------------------------------------------------------------- helloWorldApp :: Application@@ -116,7 +116,7 @@ restFilterApp :: Application restFilterApp = runApp $ do- [capture|/test/**|] . action $ \l -> contentType "text/plain" >> showing l+ [capture|/test/**rest|] . action $ contentType "text/plain" >> param [key|rest|] >>= showing [capture|/test/neko|] . action $ contentType "text/plain" >> bytes "nyan" restFilterTest :: Test@@ -133,10 +133,10 @@ captureApp :: Application captureApp = runApp $ do [capture|/foo|] . action $ contentType "text/plain" >> bytes "foo"- [capture|/:Int|] . method GET . action $ \i -> contentType "text/plain" >> bytes "Int " >> showing i- [capture|/:Double|] . action $ \i -> contentType "text/plain" >> bytes "Double " >> showing i- [capture|/bar/:L.ByteString/:Int|] . action $ \s i -> contentType "text/plain" >> lazyBytes s >> char ' ' >> showing i- [capture|/:L.ByteString|] . action $ \s -> contentType "text/plain" >> bytes "fall " >> lazyBytes s+ [capture|/int::Int|] . method GET . action $ contentType "text/plain" >> bytes "Int " >> param [key|int|] >>= showing+ [capture|/d::Double|] . action $ contentType "text/plain" >> bytes "Double " >> param [key|d|] >>= showing+ [capture|/bar/s::L.ByteString/i::Int|] . action $ contentType "text/plain" >> param [key|s|] >>= lazyBytes >> char ' ' >> param [key|i|] >>= showing+ [capture|/s::L.ByteString|] . action $ contentType "text/plain" >> bytes "fall " >> param [key|s|] >>= lazyBytes captureTest :: Test captureTest = testGroup "capture" $ map ($ captureApp)@@ -153,21 +153,15 @@ -------------------------------------------------------------------------------- queryApp f g h = runApp $ do- _ <- (f "foo" pInt) . action $ \i -> contentType "text/plain" >> bytes "foo Int " >> showing i- _ <- (g "foo" pString) . action $ \i -> contentType "text/plain" >> bytes "foo String " >> showing i- (h "foo" (pMaybe pString)) . action $ \i -> contentType "text/plain" >> bytes "foo Maybe String " >> showing i+ _ <- (f [key|foo|] pInt) . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= showing+ _ <- (g [key|foo|] pString) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= showing+ (h [key|foo|] (pMaybe pString)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= showing queryOptionalApp :: Application queryOptionalApp = runApp $ do- ("foo" =?!: (5 :: Int)) . action $ \i -> contentType "text/plain" >> bytes "foo Int " >> showing i- ("foo" =?!: ("bar" :: String)) . action $ \i -> contentType "text/plain" >> bytes "foo String " >> showing i- ("foo" =?!: (Just "baz" :: Maybe String)) . action $ \i -> contentType "text/plain" >> bytes "foo Maybe String " >> showing i--queryCheckApp :: Application-queryCheckApp = runApp $ do- ("foo" ?: pInt) . action $ contentType "text/plain" >> bytes "foo Int"- ("foo" ?: pString) . action $ contentType "text/plain" >> bytes "foo String"- ("foo" ?: pMaybe pString) . action $ contentType "text/plain" >> bytes "foo Maybe String"+ ([key|foo|] =?!: (5 :: Int)) . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= showing+ ([key|foo|] =?!: ("bar" :: String)) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= showing+ ([key|foo|] =?!: (Just "baz" :: Maybe String)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= showing queryFirstTest :: Test queryFirstTest = testGroup "First" $ map ($ queryApp (=:) (=:) (=:))@@ -199,7 +193,7 @@ , testReq "GET /?foo=12" . assertPlain200 "foo Int Just 12" , testReq "GET /?foo=a" . assertPlain200 "foo String Just \"a\"" , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int Just 12"- , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String Just \"12\""+ , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo Int Just 12" ] queryOptionalTest :: Test@@ -210,18 +204,7 @@ , testReq "GET /?foo=12" . assertPlain200 "foo Int 12" , testReq "GET /?foo=a" . assertPlain200 "foo String \"a\"" , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int 12"- , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String \"12\""- ]--queryCheckTest :: Test-queryCheckTest = testGroup "Check" $ map ($ queryCheckApp)- [ testReq "GET /" . assert404- , testReq "GET /?foo" . assertPlain200 "foo Maybe String"- , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String"- , testReq "GET /?foo=12" . assertPlain200 "foo Int"- , testReq "GET /?foo=a" . assertPlain200 "foo String"- , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int"- , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String"+ , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo Int 12" ] queryManyTest :: Test@@ -248,8 +231,10 @@ switchQueryApp :: Application switchQueryApp = runApp $ do- switchQuery "foo" . switchQuery "bar" . action $ \f b ->- contentType "text/plain" >> showing f >> showing b+ switchQuery [key|foo|] . switchQuery [key|bar|] . action $ do+ contentType "text/plain"+ param [key|foo|] >>= showing+ param [key|bar|] >>= showing switchQueryTest :: Test switchQueryTest = testGroup "switch" $ map ($ switchQueryApp)@@ -269,7 +254,6 @@ , queryOneTest , queryOptionTest , queryOptionalTest- , queryCheckTest , queryManyTest , querySomeTest , switchQueryTest@@ -278,7 +262,8 @@ -------------------------------------------------------------------------------- stopApp :: Application stopApp = runApp $ do- [capture|/a/:Int|] . action $ \i -> do+ [capture|/a/i::Int|] . action $ do+ i <- param [key|i|] contentType "text/plain" when (i == 1) $ bytes "one\n" if i `mod` 2 == 0 then bytes "even\n" else bytes "odd\n"