apiary 1.2.3 → 1.3.0

raw patch · 22 files changed

+657/−815 lines, 22 filesdep +QuickCheckdep +test-framework-quickcheckdep +web-routingdep ~blaze-builderdep ~exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, test-framework-quickcheck, web-routing

Dependency ranges changed: blaze-builder, exceptions

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• apiary.cabal +12/−10
• src/Control/Monad/Apiary/Action.hs +1/−0
• src/Control/Monad/Apiary/Action/Internal.hs +3/−5
• src/Control/Monad/Apiary/Filter.hs +72/−53
• src/Control/Monad/Apiary/Filter/Capture.hs +47/−2
• src/Control/Monad/Apiary/Filter/Internal.hs +17/−13
• src/Control/Monad/Apiary/Filter/Internal/Capture.hs +0/−64
• src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +2/−2
• src/Control/Monad/Apiary/Internal.hs +41/−113
• src/Data/Apiary/Compat.hs +1/−0
• src/Data/Apiary/Dict.hs +0/−134
• src/Data/Apiary/Param.hs +16/−13
• src/Network/Wai/Parse.hs +2/−2
• src/Web/Apiary.hs +7/−3
• src/Web/Apiary/TH.hs +18/−0
• test/Application.hs +0/−339
• test/Method.hs +0/−50
• test/main.hs +0/−12
• tests/Application.hs +340/−0
• tests/Method.hs +49/−0
• tests/main.hs +11/−0

@@ -1,3 +1,21 @@+# 1.3.0+* new router(web-routing package)+* new dictionary++    insert -\> add+    NotMember -\> (\</)  etc...++* add Filter,Filter' type+* remove focus'++    focus' -\> focus+    focus  -\> [delete]++* change boolean query behaviour++    old: ?key == fail+    new: ?key == true+ # 1.2.3 * fix haddock documentation. 

@@ -1,5 +1,5 @@ name:                apiary-version:             1.2.3+version:             1.3.0 synopsis:            Simple and type safe web framework that generate web API documentation. description:   Simple and type safe web framework that can be automatically generate API documentation.@@ -75,19 +75,18 @@                         Data.Apiary.Extension                        Data.Apiary.Param-                       Data.Apiary.Dict                        Data.Apiary.Method                        Data.Apiary.Compat                        Data.Apiary.Document                        Data.Apiary.Document.Html -  other-modules:       Network.Wai.Parse+  other-modules:       Web.Apiary.TH+                       Network.Wai.Parse                        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   build-depends:       base                 >=4.6   && <4.8                      , template-haskell     >=2.8   && <2.10@@ -120,6 +119,7 @@                       , wai                  >=3.0   && <3.1                      , stringsearch         >=0.3   && <0.4+                     , web-routing          >=0.4   && <0.5    default-extensions:  OverlappingInstances   hs-source-dirs:      src@@ -132,10 +132,12 @@   other-modules:       Application                      , Method   type:                exitcode-stdio-1.0-  build-depends:       base                 >=4.6   && <4.8-                     , mtl                  >=2.1   && <2.3-                     , test-framework       >=0.8   && <0.9-                     , test-framework-hunit >=0.3   && <0.4+  build-depends:       base                      >=4.6   && <4.8+                     , mtl                       >=2.1   && <2.3+                     , QuickCheck                >=1.2   && <1.3+                     , test-framework            >=0.8   && <0.9+                     , test-framework-hunit      >=0.3   && <0.4+                     , test-framework-quickcheck >=0.3   && <0.4                      , apiary                      , bytestring           >=0.10  && <0.11                      , http-types           >=0.8   && <0.9@@ -143,8 +145,8 @@                      , wai                  >=3.0   && <3.1                      , wai-extra            >=3.0   && <3.1 -  hs-source-dirs:      test-  ghc-options:         -O2 -Wall -fno-warn-missing-signatures+  hs-source-dirs:      tests+  ghc-options:         -Wall -fno-warn-missing-signatures   default-language:    Haskell2010  source-repository head

@@ -39,6 +39,7 @@     -- * not export from Web.Apiary     , ContentType     , stopWith+    , applyDict     -- ** getter     , getRequest     , getHeaders

@@ -75,10 +75,10 @@      -- internal     , ApiaryConfig(..)+    , getConfig     , getState     , modifyState     , getRequestBody-    , actionFetches     , execActionT     , applyDict @@ -112,7 +112,7 @@ import qualified Network.Wai.Parse as P  import Data.Monoid(Monoid(..), (<>))-import qualified Data.Apiary.Dict as Dict+import qualified Network.Routing.Dict as Dict import Data.Apiary.Param(Param, File(..)) import Data.Apiary.Compat(SProxy(..)) import Data.Apiary.Document(Documents)@@ -208,7 +208,6 @@     , actionVault       :: V.Vault     , actionContentType :: S.ByteString     , actionReqBody     :: Maybe RequestBody-    , actionFetches     :: [T.Text]     }  initialState :: ApiaryConfig -> ActionState@@ -219,7 +218,6 @@     , actionVault       = V.empty     , actionContentType = defaultContentType conf     , actionReqBody     = Nothing-    , actionFetches     = []     } {-# INLINE initialState #-} @@ -295,7 +293,7 @@  execActionT :: ApiaryConfig -> Extensions exts -> Documents -> ActionT exts '[] IO () -> Wai.Application execActionT config exts doc m request send = -    runActionT m Dict.empty (ActionEnv config request doc exts) (initialState config) >>= \case+    runActionT m Dict.emptyDict (ActionEnv config request doc exts) (initialState config) >>= \case         Pass         -> notFound config request send         Stop s       -> send s         Continue r _ -> send $ toResponse r

@@ -4,11 +4,13 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE DataKinds #-}  module Control.Monad.Apiary.Filter (+    Filter, Filter'     -- * http method-      method+    , method     -- * http version     , http09, http10, http11     -- * path matcher@@ -33,7 +35,7 @@     , query     , Control.Monad.Apiary.Filter.httpVersion -    , function, function', function_, focus, focus'+    , function, function', function_, focus     , Doc(..)     ) where @@ -46,12 +48,18 @@ import Control.Monad.Trans(MonadIO)  import Control.Monad.Apiary.Action.Internal-    (getParams, getQueryParams, getRequestBody, getRequest, ContentType, contentType)+    ( getQueryParams, getRequestBody+    , getRequest, ContentType, contentType+    , getConfig, ApiaryConfig(..)+    )+ import Control.Monad.Apiary.Filter.Internal     ( function, function', function_-    , Doc(DocMethod, DocPrecondition, DocRoot, DocQuery, DocAccept))+    , Doc(DocMethod, DocPrecondition, DocRoot, DocQuery, DocAccept)+    )+ import Control.Monad.Apiary.Filter.Internal.Capture.TH(capture)-import Control.Monad.Apiary.Internal(ApiaryT, focus', focus, PathElem(RootPath))+import Control.Monad.Apiary.Internal(Filter, Filter', focus)  import Text.Blaze.Html(Html, toHtml) import qualified Data.ByteString.Char8 as SC@@ -59,8 +67,9 @@ import qualified Data.CaseInsensitive  as CI import Data.Monoid((<>)) import Data.Apiary.Compat(KnownSymbol, Symbol, symbolVal, Proxy(..), SProxy(..))-import Data.Apiary.Dict(NotMember, Elem((:=)))-import qualified Data.Apiary.Dict as Dict+import Network.Routing.Dict(type (</), KV((:=)))+import qualified Network.Routing.Dict as Dict+import qualified Network.Routing as R  import Data.Apiary.Param     ( ReqParam, StrategyRep(..), QueryRep(NoValue)@@ -75,32 +84,37 @@ -- method GET      -- stdmethod -- 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 getParams+method :: Monad actM => Method -> Filter' exts actM m+method m = focus (DocMethod m) (Just m) id  -- | filter by ssl accessed. since 0.1.0.0.-ssl :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+ssl :: Monad actM => Filter' exts actM m ssl = function_ (DocPrecondition "SSL required") Wai.isSecure  -- | http version filter. since 0.5.0.0.-httpVersion :: Monad actM => HTTP.HttpVersion -> Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+httpVersion :: Monad actM => HTTP.HttpVersion -> Html -> Filter' exts 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 :: Monad actM => Filter' exts actM m 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 :: Monad actM => Filter' exts actM m 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 :: Monad actM => Filter' exts actM m 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:) getParams+root :: (Monad m, Monad actM) => Filter' exts actM m+root = focus DocRoot Nothing $ R.raw "ROOT" $ \d r -> do+    roots <- rootPattern <$> getConfig+    case r of+        [] -> return (d, [])+        [p] | p `elem` roots -> return (d, [])+        _  -> mzero  -------------------------------------------------------------------------------- @@ -126,21 +140,25 @@     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+query :: forall query strategy k v exts prms actM m. (k </ prms, MonadIO actM, KnownSymbol k, ReqParam v, HasDesc query, Strategy strategy)+      => query k -> strategy v -> Filter exts actM m prms (SNext strategy k v prms)+query k w = focus doc Nothing $ R.raw "query" $ \d t -> 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+    case strategy w k as d of+        Nothing -> mzero+        Just d' -> return (d', t)+  where+    doc = DocQuery (T.pack $ symbolVal k) (strategyRep w) (reqParamRep (Proxy :: Proxy v)) (queryDesc k)  -- | get first matched paramerer. since 0.5.0.0. -- -- @ -- [key|key|] =: pInt -- @-(=:) :: (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 ()+(=:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, k </ prms)+     => query k -> proxy v -> Filter exts actM m prms (k := v ': prms) k =: v = query k (pFirst v)  -- | get one matched paramerer. since 0.5.0.0.@@ -150,8 +168,8 @@ -- @ -- [key|key|] =!: pInt -- @-(=!:) :: (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 ()+(=!:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, k </ prms)+      => query k -> proxy v -> Filter exts actM m prms (k := v ': prms) k =!: t = query k (pOne t)  -- | get optional first paramerer. since 0.5.0.0.@@ -161,9 +179,8 @@ -- @ -- [key|key|] =?: pInt -- @-(=?:) :: (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 ()+(=?:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, k </ prms)+      => query k -> proxy v -> Filter exts actM m prms (k := Maybe v ': prms) k =?: t = query k (pOption t)  -- | get optional first paramerer with default. since 0.16.0.@@ -173,9 +190,8 @@ -- @ -- [key|key|] =!?: (0 :: Int) -- @-(=?!:) :: 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 ()+(=?!:) :: forall query k v exts prms actM m. (HasDesc query, MonadIO actM, Show v, ReqParam v, KnownSymbol k, k </ prms)+       => query k -> v -> Filter exts actM m prms (k := v ': prms) k =?!: v = query k (pOptional v)  -- | get many paramerer. since 0.5.0.0.@@ -183,9 +199,8 @@ -- @ -- [key|key|] =*: pInt -- @-(=*:) :: (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 ()+(=*:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, k </ prms)+      => query k -> proxy v -> Filter exts actM m prms (k := [v] ': prms) k =*: t = query k (pMany t)  -- | get some paramerer. since 0.5.0.0.@@ -193,48 +208,52 @@ -- @ -- [key|key|] =+: pInt -- @-(=+:) :: (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 ()+(=+:) :: (HasDesc query, MonadIO actM, ReqParam v, KnownSymbol k, k </ prms)+      => query k -> proxy v -> Filter exts actM m prms (k := [v] ': prms) k =+: t = query k (pSome t)  -- | get existance of key only query parameter. since v0.17.0.-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+switchQuery :: (HasDesc proxy, MonadIO actM, KnownSymbol k, k </ prms)+            => proxy k -> Filter exts actM m prms (k := Bool ': prms)+switchQuery k = focus doc Nothing $ R.raw "switch" $ \d t -> 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-    Dict.insert k n <$> getParams+    return (Dict.add k n d, t)+  where+    doc = (DocQuery (T.pack $ symbolVal k) (StrategyRep "switch") NoValue (queryDesc k))  --------------------------------------------------------------------------------  -- | 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+header :: (KnownSymbol k, Monad actM, k </ prms)+       => proxy k -> Filter exts actM m prms (k := SC.ByteString ': prms)+header k = focus doc Nothing $ R.raw "header" $ \d t -> do     n <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . Wai.requestHeaders =<< getRequest-    Dict.insert k n <$> getParams+    return (Dict.add k n d, t)+  where+    doc = DocPrecondition $ "has header: " <> toHtml (symbolVal k)  -- | check whether to exists specified valued header or not. since 0.6.0.0. 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+         => proxy k -> SC.ByteString -> Filter' exts actM m+eqHeader k v = focus doc Nothing $ R.raw "=header" $ \d t -> do     v' <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . Wai.requestHeaders =<< getRequest-    if v == v' then getParams else mzero-+    if v == v' then return (d,t) else mzero+  where+    doc = DocPrecondition $ "header: " <> toHtml (symbolVal k) <> " = " <> toHtml (show v)  -- | 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 (DocAccept ect) $+accept :: Monad actM => ContentType -> Filter' exts actM m+accept ect = focus (DocAccept ect) Nothing $ R.raw "accept" $ \d t ->     (lookup "Accept" . Wai.requestHeaders <$> getRequest) >>= \case         Nothing -> mzero-        Just ac -> +        Just ac ->             let ex@(et, _) = parseContentType ect                 accepts    = map parseContentType (parseHttpAccept ac)             in case filter (matchContentType ex) accepts of-                []      -> mzero-                (_,p):_ -> contentType (prettyContentType et p) >> getParams+                [] -> mzero+                (_,p):_ -> contentType (prettyContentType et p) >> return (d, t)  matchContentType :: (SC.ByteString, [(SC.ByteString, SC.ByteString)])                  -> (SC.ByteString, [(SC.ByteString, SC.ByteString)])

@@ -1,5 +1,50 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-}+ module Control.Monad.Apiary.Filter.Capture-    ( path, endPath, fetch, anyPath, restPath+    ( path, fetch, fetch', anyPath, restPath     ) where -import Control.Monad.Apiary.Filter.Internal.Capture+import Control.Monad.Apiary.Internal (Filter, Filter', focus)+import Control.Monad.Apiary.Filter.Internal+    (Doc(DocPath, DocFetch, DocAny, DocRest))++import Data.Apiary.Compat(KnownSymbol, symbolVal, Proxy(..))+import Data.Apiary.Param(Path, pathRep, readPathAs)+import Network.Routing.Dict(KV((:=)))+import qualified Network.Routing.Dict as Dict+import qualified Network.Routing as R++import qualified Data.Text as T+import Text.Blaze.Html(Html)++-- | check first path and drill down. since 0.11.0.+path :: Monad actM => T.Text -> Filter' exts actM m+path p = focus (DocPath p) Nothing (R.exact p)++-- | get first path and drill down. since 0.11.0.+fetch' :: (k Dict.</ prms, KnownSymbol k, Path p, Monad actM) => proxy k -> proxy' p -> Maybe Html+       -> Filter exts actM m prms (k := p ': prms)+fetch' k p h = focus (DocFetch (T.pack $ symbolVal k) (pathRep p) h) Nothing $ R.fetch k (readPathAs p)++fetch :: forall proxy k p exts prms actM m. (k Dict.</ prms, KnownSymbol k, Path p, Monad actM)+      => proxy (k := p) -> Maybe Html+      -> Filter exts actM m prms (k := p ': prms)+fetch _ h = fetch' k p h+  where+    k = Proxy :: Proxy k+    p = Proxy :: Proxy p++anyPath :: (Monad m, Monad actM) => Filter' exts actM m+anyPath = focus DocAny Nothing R.any++restPath :: (k Dict.</ prms, KnownSymbol k, Monad m, Monad actM)+         => proxy k -> Maybe Html+         -> Filter exts actM m prms (k := [T.Text] ': prms)+restPath k h = focus (DocRest (T.pack $ symbolVal k) h) Nothing (R.rest k)

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} @@ -12,28 +13,31 @@ import qualified Network.Wai as Wai  import Control.Monad(mzero)-import Control.Monad.Apiary.Internal(ApiaryT, focus)-import Control.Monad.Apiary.Action(getParams, getRequest)+import Control.Monad.Apiary.Internal(Filter, Filter', focus)+import Control.Monad.Apiary.Action(getRequest)  import Data.Apiary.Compat(KnownSymbol)-import Data.Apiary.Dict(Dict, NotMember, Elem((:=)))-import qualified Data.Apiary.Dict as Dict+import Network.Routing.Dict(type (</), KV((:=)), Store)+import qualified Network.Routing.Dict as Dict+import qualified Network.Routing as R import Data.Apiary.Document.Internal(Doc(..))  -- | low level filter function. function :: Monad actM => (Doc -> Doc)-         -> (Dict prms -> Wai.Request -> Maybe (Dict prms'))-         -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m ()-function d f = focus d $ getParams >>= \p -> getRequest >>= \r -> case f p r of-    Nothing -> mzero-    Just c' -> return c'+         -> (Store prms -> Wai.Request -> Maybe (Store prms'))+         -> Filter exts actM m prms prms'+function doc f = focus doc Nothing $ R.raw "function" $ \d t -> do+    req <- getRequest+    case f d req of+        Nothing -> mzero+        Just c' -> return (c', t)  -- | filter and append argument.-function' :: (KnownSymbol key, Monad actM, NotMember key prms) => (Doc -> Doc) -> (Wai.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 $ Dict.insert k p c+function' :: (KnownSymbol key, Monad actM, key </ prms) => (Doc -> Doc) -> (Wai.Request -> Maybe (proxy key, prm))+          -> Filter exts actM m prms (key := prm ': prms)+function' d f = function d $ \c r -> f r >>= \(k, p) -> return $ Dict.add k p c  -- | filter only(not modify arguments). function_ :: Monad actM => (Doc -> Doc) -> (Wai.Request -> Bool) -          -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+          -> Filter' exts actM m function_ d f = function d $ \c r -> if f r then Just c else Nothing

@@ -1,64 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DataKinds #-}--module Control.Monad.Apiary.Filter.Internal.Capture-    ( path, endPath, fetch, fetch', anyPath, restPath ) where--import Control.Applicative((<$>), (<$))-import Control.Monad(liftM, mzero)-import Control.Monad.Apiary.Action.Internal-    (getParams, actionFetches, getState, modifyState)-import Control.Monad.Apiary.Internal-    (ApiaryT, focus', PathElem(Exact, FetchPath, RestPath, EndPath))-import Control.Monad.Apiary.Filter.Internal-    (Doc(DocPath, DocFetch, DocAny, DocRest))--import Data.Apiary.Compat(KnownSymbol, symbolVal, Proxy(..))-import Data.Apiary.Param(Path, pathRep, readPathAs)-import Data.Apiary.Dict(Elem((:=)))-import qualified Data.Apiary.Dict as Dict--import qualified Data.Text as T-import Text.Blaze.Html(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:) 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:) getParams---- | get first path and drill down. since 0.11.0.-fetch' :: (Dict.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  -> do-            modifyState (\s -> s {actionFetches = fs})-            Dict.insert k r <$> getParams-        Nothing -> mzero---fetch :: forall proxy k p exts prms actM m. (Dict.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 :: (Dict.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 $ Dict.insert k [] l-    fs -> Dict.insert k fs l <$ modifyState (\s -> s {actionFetches = []})

@@ -11,7 +11,7 @@ import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote(QuasiQuoter(..)) -import qualified Control.Monad.Apiary.Filter.Internal.Capture as Capture+import qualified Control.Monad.Apiary.Filter.Capture as Capture  import qualified Data.Text as T import Data.String(IsString(..))@@ -44,7 +44,7 @@         (_, _)         -> fail "capture: syntax error."   mkCap :: [String] -> TH.ExpQ-mkCap [] = [|Capture.endPath|]+mkCap [] = [|id|] mkCap (('*':'*':[]):as) = [|Capture.anyPath . $(mkCap as) |] mkCap (('*':'*':tS):as) = do     (k, d) <- description tS

@@ -1,7 +1,9 @@+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE CPP #-}@@ -26,15 +28,15 @@     , apiaryExt      -- internal-    , focus, focus'-    , PathElem(..)+    , Filter+    , Filter'+    , focus     ) where - import qualified Network.Wai as Wai  import Control.Applicative(Applicative(..), (<$>))-import Control.Monad(liftM, MonadPlus(..))+import Control.Monad(liftM) import Control.Monad.Trans(MonadIO(liftIO), MonadTrans(lift)) import Control.Monad.Trans.Control     ( MonadTransControl(..), MonadBaseControl(..)@@ -43,87 +45,42 @@ import Control.Monad.Base(MonadBase(..)) import Control.Monad.Apiary.Action.Internal     (ActionT, ApiaryConfig, getRequest-    , modifyState, actionFetches, Extensions(NoExtension)+    , Extensions(NoExtension)     , execActionT, hoistActionT, applyDict, rootPattern     ) -import qualified Data.Apiary.Dict as D+import qualified Network.Routing as R import Data.Apiary.Method(Method, renderMethod) import Data.Apiary.Extension ( Has, MonadExts(..), getExt, noExtension ) import Data.Apiary.Extension.Internal(Initializer(..), allMiddleware, allMiddleware') import Data.Apiary.Document.Internal(Doc(..), docsToDocuments) import Data.Monoid(Monoid(..), (<>)) -import Data.List(foldl') import Text.Blaze.Html(Html) import qualified Data.Text as T-import qualified Data.ByteString as S-import qualified Data.HashMap.Strict as H -data Router exts actM = Router-    { children   :: H.HashMap T.Text (Router exts actM)-    , capturing  :: Maybe (Router exts actM)-    , restMatch  :: Maybe (PathMethod exts actM)-    , pathMethod :: PathMethod exts actM-    }--type ActionT' exts actM a = ActionT exts '[] actM a--data PathMethod exts actM = PathMethod-    { methodMap :: H.HashMap S.ByteString (ActionT' exts actM ())-    , anyMethod :: Maybe (ActionT' exts actM ())-    }--emptyRouter :: Router exts actM-emptyRouter = Router H.empty Nothing Nothing emptyPathMethod--emptyPathMethod :: PathMethod exts actM-emptyPathMethod = PathMethod H.empty Nothing--insertRouter :: Monad actM => [T.Text] -> Maybe S.ByteString -> [PathElem]-             -> ActionT' exts actM () -> Router exts actM -> Router exts actM-insertRouter rootPat mbMethod paths act = loop paths-  where-    loop [EndPath] (Router cln cap anp pm) =-        Router cln cap anp $ insPathMethod pm--    loop [] (Router cln cap anp pm) =-        Router cln cap (Just . insPathMethod $ maybe emptyPathMethod id anp) pm--    loop (mbp:ps) rtr@(Router cln cap anp pm) = case mbp of-        FetchPath -> Router cln (Just $ loop ps (maybe emptyRouter id cap)) anp pm-        Exact p   -> Router (adjust' (loop ps) p cln) cap anp pm-        EndPath   -> loop ps rtr-        RestPath  -> Router cln cap (Just . insPathMethod $ maybe emptyPathMethod id anp) pm-        RootPath  -> let cln' = foldl' (flip $ adjust' (loop [EndPath])) cln rootPat-                     in loop [EndPath] $ Router cln' cap anp pm--    adjust' f k h = H.adjust f k (H.insertWith (\_ old -> old) k emptyRouter h)+-- | routing filter+type Filter exts actM m inp out =+    ApiaryT exts out actM m () -> ApiaryT exts inp actM m () -    insPathMethod (PathMethod mm am) = case mbMethod of-        Nothing -> PathMethod mm (Just $ maybe act (mplus act) am)-        Just m  -> PathMethod (H.insertWith mplus m act mm) am+-- | routing filter(without modify parameter dictionary)+type Filter' exts actM m = forall prms. Filter exts actM m prms prms -data PathElem = Exact {-# UNPACK #-} !T.Text-              | FetchPath-              | RootPath-              | EndPath-              | RestPath+type ActionT' exts actM = ActionT exts '[] actM  data ApiaryEnv exts prms actM = ApiaryEnv-    { envFilter :: ActionT' exts actM (D.Dict prms)-    , envMethod :: Maybe Method-    , envPath   :: [PathElem] -> [PathElem]+    { envMethod :: Maybe Method+    , envPath   :: R.Path prms (ActionT' exts actM) () -> R.Path '[] (ActionT' exts actM) ()     , envConfig :: ApiaryConfig     , envDoc    :: Doc -> Doc     , envExts   :: Extensions exts     }  initialEnv :: Monad actM => ApiaryConfig -> Extensions exts -> ApiaryEnv exts '[] actM-initialEnv conf = ApiaryEnv (return D.empty) Nothing id conf id+initialEnv conf = ApiaryEnv Nothing id conf id  data ApiaryWriter exts actM = ApiaryWriter-    { writerRouter :: Router exts actM -> Router exts actM+    { writerRouter :: R.Router '[] (ActionT' exts actM) () -> R.Router '[] (ActionT' exts actM) ()     , writerDoc    :: [Doc] -> [Doc]     , writerMw     :: Wai.Middleware     }@@ -145,31 +102,10 @@         -> 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-  where-    go req = loop id router (Wai.pathInfo req)-      where-        method = Wai.requestMethod req--        pmAction nxt (PathMethod mm am) =-            let a = maybe nxt id am-            in maybe a (`mplus` a) $ H.lookup method mm--        loop fch (Router _ _ anp pm) [] = do-            modifyState (\s -> s { actionFetches = fch [] } )-            pmAction (maybe mzero (pmAction mzero) anp) pm --        loop fch (Router c mbcp anp _) (p:ps) = case mbcp of-            Nothing -> cld ana-            Just cp -> cld $ loop (fch . (p:)) cp ps `mplus` ana-          where-            ana = do-                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+routerToAction :: Monad actM => R.Router '[] (ActionT' exts actM) () -> ActionT' exts actM ()+routerToAction router = do+    req <- getRequest+    R.execute router (Wai.requestMethod req) (Wai.pathInfo req)  -- | run Apiary monad. runApiaryTWith :: (Monad actM, Monad m)@@ -182,7 +118,7 @@ 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+        rtr = writerRouter wtr R.empty         mw  = allMiddleware exts . writerMw wtr         mw' = allMiddleware' exts         app = mw $ execActionT conf exts doc (mw' $ hoistActionT runAct $ routerToAction rtr)@@ -279,36 +215,28 @@ addRoute :: Monad actM => ApiaryWriter exts actM -> ApiaryT exts prms actM m () addRoute r = ApiaryT $ \_ cont -> cont () r --- | filter by action. since 0.6.1.0.+-- | filter by action. since 1.3.0. focus :: Monad actM       => (Doc -> Doc)-      -> 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--focus' :: Monad actM-       => (Doc -> Doc)-       -> Maybe Method-       -> ([PathElem] -> [PathElem])-       -> 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 >>= flip applyDict g-    , envMethod = maybe (envMethod env) Just meth-    , envPath   = envPath env . pth-    , envDoc    = envDoc env  . d+      -> Maybe Method+      -> (R.Path prms' (ActionT exts '[] actM) () -> R.Path prms (ActionT exts '[] actM) ())+      -> Filter exts actM m prms prms'+focus d meth pth m = ApiaryT $ \ApiaryEnv{..} cont -> unApiaryT m ApiaryEnv+    { envMethod = maybe envMethod Just meth+    , envPath   = envPath . pth+    , envDoc    = envDoc  . d+    , envConfig = envConfig+    , envExts   = envExts     } cont  -- | splice ActionT to ApiaryT. action :: Monad actM => ActionT exts prms actM () -> ApiaryT exts prms actM m () action a = do     env <- getApiaryEnv+    let meth = renderMethod <$> envMethod env+        path = envPath env (R.action meth $ flip applyDict a)     addRoute $ ApiaryWriter-        (insertRouter-            (rootPattern $ envConfig env)-            (renderMethod <$> envMethod env)-            (envPath env [])-            (envFilter env >>= flip applyDict a))+        (R.insert path)         (envDoc env Action:)         id @@ -318,27 +246,27 @@  -------------------------------------------------------------------------------- -insDoc :: (Doc -> Doc) -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+insDoc :: (Doc -> Doc) -> Filter' exts actM m insDoc d m = ApiaryT $ \env cont -> unApiaryT m env     { envDoc = envDoc env . d } cont  -- | API document group. since 0.12.0.0. -- -- only top level group recognized.-group :: T.Text -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+group :: T.Text -> Filter' exts actM m group = insDoc . DocGroup  -- | add API document. since 0.12.0.0. -- -- It use only filters prior document, -- so you should be placed document directly in front of action.-document :: T.Text -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+document :: T.Text -> Filter' exts actM m document = insDoc . Document  -- | add user defined precondition. since 0.13.0.-precondition :: Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+precondition :: Html -> Filter' exts actM m precondition = insDoc . DocPrecondition  -- | ignore next document.-noDoc :: ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+noDoc :: Filter' exts actM m noDoc = insDoc DocDropNext

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE KindSignatures #-}

@@ -1,134 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE CPP #-}---- | type sefe dictionaly.-module Data.Apiary.Dict-    ( Dict-    , empty-    , insert-    , Member(get)-    , key--    -- * types-    , Elem((:=))-    , NotMember-    , Member'-    , Members-    ) where--import Data.Apiary.Compat(KnownSymbol, Symbol, symbolVal, SProxy(..))--import qualified Language.Haskell.TH as TH-import Language.Haskell.TH.Quote(QuasiQuoter(..))--import qualified Data.HashMap.Strict as H-import qualified Data.Text as T--import GHC.Exts(Any, Constraint)-import Unsafe.Coerce---- | (kind) Dict element.-data Elem = forall a. Symbol := a--newtype Dict (ks :: [Elem]) = Dict (H.HashMap T.Text Any)--class Member (k :: Symbol) (v :: *) (kvs :: [Elem]) | k kvs -> v where--    -- | get value of key.-    ---    -- > ghci> get (Proxy :: Proxy "bar") $ insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty-    -- > 0.5-    ---    -- > ghci> get (Proxy :: Proxy "foo") $ insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty-    -- > 12-    ---    -- ghc raise compile error when key is not exists.-    ---    -- > ghci> get (Proxy :: Proxy "baz") $ insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "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--getImpl :: KnownSymbol k => proxy k -> Dict any -> b-getImpl p (Dict d) = maybe (error "Dict: no value.") unsafeCoerce $ H.lookup (T.pack $ symbolVal p) d--instance KnownSymbol k => Member k v (k := v ': kvs) where-    get = getImpl--instance (KnownSymbol k, Member k v kvs) => Member k v (k' := v' ': kvs) where-    get = getImpl---- | 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 = Dict H.empty---- | insert element.--- --- > ghci> :t insert (Proxy :: Proxy "foo") (12 :: Int) empty--- > insert (Proxy :: Proxy "foo") (12 :: Int) empty--- >   :: Dict '["foo" ':= Int]--- --- > ghci> :t insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty--- > insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty--- >   :: Dict '["bar" ':= Double, "foo" ':= Int]------ ghc raise compile error when insert duplicated key(> ghc-7.8 only).------ > ghci> :t insert (Proxy :: Proxy "foo") (0.5 :: Double) $ insert (Proxy :: Proxy "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 (Proxy :: Proxy "foo") (0.5 :: Double)--- >     In the expression:--- >       insert (Proxy :: Proxy "foo") (0.5 :: Double)--- >       $ insert (Proxy :: Proxy "foo") (12 :: Int) empty--insert :: (KnownSymbol k, NotMember k kvs) => proxy k -> v -> Dict kvs -> Dict (k := v ': kvs)-insert p v (Dict d) = Dict (H.insert (T.pack $ symbolVal p) (unsafeCoerce v) d)---- | construct string literal proxy.------ prop> [key|foo|] == (Proxy :: Proxy "foo")----key :: QuasiQuoter-key = QuasiQuoter-    { quoteExp  = \s -> [| SProxy :: SProxy $(TH.litT $ TH.strTyLit s) |]-    , quotePat  = error "key qq only exp or type."-    , quoteType = \s -> [t| SProxy $(TH.litT $ TH.strTyLit s) |]-    , quoteDec  = error "key qq only exp or type."-    }

@@ -57,8 +57,8 @@ import Data.Int(Int8, Int16, Int32, Int64) import Data.Word(Word, Word8, Word16, Word32, Word64) import Data.Maybe(isJust, catMaybes)-import Data.Apiary.Dict(Elem((:=)), NotMember, Dict)-import qualified Data.Apiary.Dict as Dict+import Network.Routing.Dict(KV((:=)), type (</), Store)+import qualified Network.Routing.Dict as Dict import Data.Apiary.Compat     ( Typeable, mkTyConApp, typeRepTyCon, typeOf, TypeRep, typeRep, Proxy(..)     , Symbol, KnownSymbol@@ -190,7 +190,10 @@  -- | javascript boolean. -- when \"false\", \"0\", \"-0\", \"\", \"null\", \"undefined\", \"NaN\" then False, else True. since 0.6.0.0.-instance Query Bool    where readQuery = fmap jsToBool; qTypeRep = typeRep+instance Query Bool    where+    readQuery (Just b) = Just $ jsToBool b+    readQuery Nothing  = Just True+    qTypeRep = typeRep  instance Query Int     where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep instance Query Int8    where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep@@ -330,51 +333,51 @@   class Strategy (w :: * -> *) where-    type SNext w (k::Symbol) a (prms :: [Elem]) :: [Elem]-    strategy :: (KnownSymbol k, NotMember k prms, MonadPlus m) => w a -> proxy' k -> [Maybe a] -> Dict prms -> m (Dict (SNext w k a prms))+    type SNext w (k::Symbol) a (prms :: [KV *]) :: [KV *]+    strategy :: (KnownSymbol k, k </ prms, MonadPlus m) => w a -> proxy' k -> [Maybe a] -> Store prms -> m (Store (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 $ Dict.insert k a d+    strategy _ k (Just a:_) d = return $ Dict.add 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 $ Dict.insert k a d+    strategy _ k [Just a] d = return $ Dict.add 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 $ Dict.insert k (catMaybes as) d else mzero+    strategy _ k as d = if all isJust as then return $ Dict.add 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 $ Dict.insert k (catMaybes as) d else mzero+    strategy _ k as d = if all isJust as then return $ Dict.add 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 $ Dict.insert k (Just a) d+    strategy _ k (Just a:_)  d = return $ Dict.add k (Just a) d     strategy _ _ (Nothing:_) _ = mzero-    strategy _ k []          d = return $ Dict.insert k Nothing d+    strategy _ k []          d = return $ Dict.add 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 $ Dict.insert k a d+    strategy _              k (Just a:_)  d = return $ Dict.add k a d     strategy _              _ (Nothing:_) _ = mzero-    strategy (Optional _ a) k []          d = return $ Dict.insert k a d+    strategy (Optional _ a) k []          d = return $ Dict.add k a d     strategyRep (Optional a _) = StrategyRep $ "default:" `T.append` a  pFirst :: proxy a -> First a

@@ -6,7 +6,7 @@ {-# LANGUAGE RankNTypes #-} -- | Some helpers for parsing data out of a raw WAI 'Request'. ----- copy from wai-extra 3.0.3.+-- copy from wai-extra 3.0.4.1.  module Network.Wai.Parse     ( parseHttpAccept@@ -351,7 +351,7 @@                 NoBound -> do                     -- don't emit newlines, in case it's part of a bound                     let (toEmit, front') =-                            if not (S8.null bs) && S8.last bs `elem` "\r\n"+                            if not (S8.null bs) && S8.last bs `elem` ['\r','\n']                                 then let (x, y) = S.splitAt (S.length bs - 2) bs                                       in (x, S.append y)                                 else (bs, id)

@@ -1,3 +1,5 @@+{-# LANGUAGE ExplicitNamespaces #-}+ module Web.Apiary      ( module Control.Monad.Apiary     , module Control.Monad.Apiary.Action@@ -9,8 +11,9 @@     , module Data.Apiary.Method     -- | Has, MonadHas, Extensions, Initializer, Initializer', (+>), noExtension     , module Data.Apiary.Extension-    -- | key, Member, Members, NotMember, Elem((:=))-    , module Data.Apiary.Dict+    -- | Member, Members, NotMember, Elem((:=))+    , module Network.Routing.Dict+    , key      -- | hiding mkStatus     , module Network.HTTP.Types.Status@@ -89,7 +92,7 @@  import Data.Apiary.Method(Method(..)) import Data.Apiary.Extension(Has, MonadExts(..), getExt, Extensions, Initializer, Initializer', (+>), noExtension)-import Data.Apiary.Dict(key, Member, Members, NotMember, Elem((:=)))+import Network.Routing.Dict (Members, type (</), KV((:=)))  import Network.HTTP.Types.Status hiding (mkStatus) import Data.Default.Class(def)@@ -97,3 +100,4 @@ import Control.Monad (MonadPlus(..), msum, mfilter, guard, (>=>)) import Network.Wai(FilePart(..), Application) import Text.Blaze.Html(Html)+import Web.Apiary.TH(key)

@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module Web.Apiary.TH(key) where++import Data.Apiary.Compat(SProxy(..))+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import qualified Language.Haskell.TH as TH++-- | construct string literal proxy.+--+-- prop> [key|foo|] == (Proxy :: Proxy "foo")+--+key :: QuasiQuoter+key = QuasiQuoter+    { quoteExp  = \s -> [| SProxy :: SProxy $(TH.litT $ TH.strTyLit s) |]+    , quotePat  = error "key qq only exp or type."+    , quoteType = \s -> [t| SProxy $(TH.litT $ TH.strTyLit s) |]+    , quoteDec  = error "key qq only exp or type."+    }

@@ -1,339 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE DataKinds #-}--module Application where--import Test.Framework-import Test.Framework.Providers.HUnit--import Control.Monad-import Control.Monad.Identity--import Web.Apiary-import Network.Wai-import Network.Wai.Test-import qualified Network.HTTP.Types as HTTP--import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as S--testReq :: String -> (Request -> IO ()) -> Test-testReq str f = -    let (meth, other) = break (== ' ') str-        (p,  version) = break (== ' ') (tail other)-    in testCase str $ f (setPath (setVersion version $ (defaultRequest { requestMethod = S.pack meth })) (S.pack p))-  where-    setVersion [] r = r-    setVersion v r | v == " HTTP/1.0" = r { Network.Wai.httpVersion = HTTP.http10 }-                   | v == " HTTP/0.9" = r { Network.Wai.httpVersion = HTTP.http09 }-                   | otherwise        = r { Network.Wai.httpVersion = HTTP.http11 }-----------------------------------------------------------------------------------assertRequest :: Int -> (Maybe S.ByteString) -> L.ByteString -> Application -> Request -> IO ()-assertRequest sc ct body app req = flip runSession app $ do-    res <- request req-    assertBody body res-    assertStatus sc res-    maybe (return ()) (flip assertContentType res) ct--assertPlain200 :: L.ByteString -> Application -> Request -> IO ()-assertPlain200 = assertRequest 200 (Just "text/plain")--assertHtml200 :: L.ByteString -> Application -> Request -> IO ()-assertHtml200 = assertRequest 200 (Just "text/html")--assertJson200 :: L.ByteString -> Application -> Request -> IO ()-assertJson200 = assertRequest 200 (Just "application/json")--assert404 :: Application -> Request -> IO ()-assert404 = assertRequest 404 (Just "text/plain") "404 Page Notfound.\n"-----------------------------------------------------------------------------------runApp :: ApiaryT '[] '[] IO Identity () -> Application-runApp = runIdentity . runApiary return def-----------------------------------------------------------------------------------helloWorldApp :: Application-helloWorldApp = runApp $ action $ do-    contentType "text/plain"-    bytes "hello"--helloWorldAllTest :: Test-helloWorldAllTest = testGroup "helloWorld" $ map ($ helloWorldApp)-    [ testReq "GET /"    . assertPlain200 "hello"-    , testReq "GET /foo" . assertPlain200 "hello"-    , testReq "POST /"   . assertPlain200 "hello"-    ]------------------------------------------------------------------------------------methodFilterApp :: Application-methodFilterApp = runApp $ do-    method "GET" . action $ contentType "text/plain" >> bytes "GET"-    method POST  . action $ contentType "text/plain" >> bytes "POST"--methodFilterTest :: Test-methodFilterTest = testGroup "methodFilter" $ map ($methodFilterApp)-    [ testReq "GET /"    . assertPlain200 "GET"-    , testReq "POST /"   . assertPlain200 "POST"-    , testReq "GET /foo" . assertPlain200 "GET"-    , testReq "DELETE /" . assert404-    ]------------------------------------------------------------------------------------httpVersionApp :: Application-httpVersionApp = runApp $ do-    http09 . action $ contentType "text/plain" >> bytes "09"-    http10 . action $ contentType "text/plain" >> bytes "10"-    http11 . action $ contentType "text/plain" >> bytes "11"--httpVersionTest :: Test-httpVersionTest = testGroup "httpVersionFilter" $ map ($ httpVersionApp)-    [ testReq "GET / HTTP/0.9" . assertPlain200 "09"-    , testReq "GET / HTTP/1.0" . assertPlain200 "10"-    , testReq "GET / HTTP/1.1" . assertPlain200 "11"-    ]------------------------------------------------------------------------------------rootFilterApp :: Application-rootFilterApp = runApp . root . action $ do-    contentType "text/html"-    bytes "root"--rootFilterTest :: Test-rootFilterTest = testGroup "rootFilter" $ map ($ rootFilterApp)-    [ testReq "GET /"           . assertHtml200 "root"-    , testReq "POST /"          . assertHtml200 "root"-    , testReq "GET /neko"       . assert404-    , testReq "GET /index.html" . assertHtml200 "root"-    ]------------------------------------------------------------------------------------restFilterApp :: Application-restFilterApp = runApp $ do-    [capture|/test/**rest|] . action $ contentType "text/plain" >> param [key|rest|] >>= showing-    [capture|/test/neko|] . action $ contentType "text/plain" >> bytes "nyan"--restFilterTest :: Test-restFilterTest = testGroup "rest capture" $ map ($ restFilterApp)-    [ testReq "GET /" . assert404-    , testReq "GET /test" . assertPlain200 "[]"-    , testReq "GET /test/foo" . assertPlain200 "[\"foo\"]"-    , testReq "GET /test/foo/bar" . assertPlain200 "[\"foo\",\"bar\"]"-    , testReq "GET /test/neko" . assertPlain200 "nyan"-    ]------------------------------------------------------------------------------------captureApp :: Application-captureApp = runApp $ do-    [capture|/foo|]  . action $ contentType "text/plain" >> bytes "foo"-    [capture|/int::Int|] . method GET . action $ contentType "text/plain" >> bytes "Int " >> param [key|int|] >>= appendShowing-    [capture|/d::Double|] . action $ contentType "text/plain" >> bytes "Double " >> param [key|d|] >>= appendShowing-    [capture|/bar/s::L.ByteString/i::Int|] . action $ contentType "text/plain" >> param [key|s|] >>= lazyBytes >> appendChar ' ' >> param [key|i|] >>= appendShowing-    [capture|/s::L.ByteString|] . action $ contentType "text/plain" >> bytes "fall " >> param [key|s|] >>= appendLazyBytes--captureTest :: Test-captureTest = testGroup "capture" $ map ($ captureApp)-    [ testReq "GET /foo"  . assertPlain200 "foo"-    , testReq "GET /12"   . assertPlain200 "Int 12"-    , testReq "GET /12.4" . assertPlain200 "Double 12.4"-    , testReq "POST /12"  . assertPlain200 "Double 12.0"-    , testReq "GET /bar"  . assertPlain200 "fall bar"-    , testReq "GET /baz"  . assertPlain200 "fall baz"-    , testReq "GET /bar/nyan/12"       . assertPlain200 "nyan 12"-    , testReq "GET /bar/nyan/12/other" . assert404-    ]------------------------------------------------------------------------------------queryApp f g h = runApp $ do-    _ <- (f [key|foo|] pInt)    . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing-    _ <- (g [key|foo|] pString) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing-    (h [key|foo|] (pMaybe pString)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing--queryOptionalApp :: Application-queryOptionalApp = runApp $ do-    ([key|foo|] =?!: (5 :: Int))                   . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing-    ([key|foo|] =?!: ("bar" :: String))            . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing-    ([key|foo|] =?!: (Just "baz" :: Maybe String)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing--queryFirstTest :: Test-queryFirstTest = testGroup "First" $ map ($ queryApp (=:) (=:) (=:))-    [ testReq "GET /" . assert404-    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing"-    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Nothing"-    , 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 Int 12"-    ]--queryOneTest :: Test-queryOneTest = testGroup "One" $ map ($ queryApp (=!:) (=!:) (=!:))-    [ testReq "GET /" . assert404-    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing"-    , testReq "GET /?foo&foo=3" . assert404-    , testReq "GET /?foo=12" . assertPlain200 "foo Int 12"-    , testReq "GET /?foo=a" . assertPlain200 "foo String \"a\""-    , testReq "GET /?foo=12&foo=23" . assert404-    , testReq "GET /?foo=12&foo=b" . assert404-    ]--queryOptionTest :: Test-queryOptionTest = testGroup "Option" $ map ($ queryApp (=?:) (=?:) (=?:))-    [ testReq "GET /" . assertPlain200 "foo Int Nothing"-    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Just Nothing"-    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Just Nothing"-    , 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 Int Just 12"-    ]--queryOptionalTest :: Test-queryOptionalTest = testGroup "Optional" $ map ($ queryOptionalApp)-    [ testReq "GET /" . assertPlain200 "foo Int 5"-    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing"-    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Nothing"-    , 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 Int 12"-    ]--queryManyTest :: Test-queryManyTest = testGroup "Many" $ map ($ queryApp (=*:) (=*:) (=*:))-    [ testReq "GET /" . assertPlain200 "foo Int []"-    , testReq "GET /?foo" . assertPlain200 "foo Maybe String [Nothing]"-    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String [Nothing,Just \"3\"]"-    , 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,23]"-    , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String [\"12\",\"b\"]"-    ]--querySomeTest :: Test-querySomeTest = testGroup "Some" $ map ($ queryApp (=+:) (=+:) (=+:))-    [ testReq "GET /" . assert404-    , testReq "GET /?foo" . assertPlain200 "foo Maybe String [Nothing]"-    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String [Nothing,Just \"3\"]"-    , 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,23]"-    , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String [\"12\",\"b\"]"-    ]--switchQueryApp :: Application-switchQueryApp = runApp $ do-    switchQuery [key|foo|] . switchQuery [key|bar|] . action $ do-        contentType "text/plain"-        param [key|foo|] >>= showing-        param [key|bar|] >>= appendShowing--switchQueryTest :: Test-switchQueryTest = testGroup "switch" $ map ($ switchQueryApp)-    [ testReq "GET /"                    . assertPlain200 "FalseFalse"-    , testReq "GET /?foo"                . assertPlain200 "TrueFalse"-    , testReq "GET /?foo&bar"            . assertPlain200 "TrueTrue"-    , testReq "GET /?foo=true"           . assertPlain200 "TrueFalse"-    , testReq "GET /?foo=false"          . assertPlain200 "FalseFalse"-    , testReq "GET /?foo=false&bar=true" . assertPlain200 "FalseTrue"-    , testReq "GET /?foo&bar=true"       . assertPlain200 "TrueTrue"-    , testReq "GET /?foo=1&bar=0"        . assertPlain200 "TrueFalse"-    ]--queryTest :: Test-queryTest = testGroup "query"-    [ queryFirstTest-    , queryOneTest-    , queryOptionTest-    , queryOptionalTest-    , queryManyTest-    , querySomeTest-    , switchQueryTest-    ]-----------------------------------------------------------------------------------stopApp :: Application-stopApp = runApp $ 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 appendBytes "even\n" else appendBytes "odd\n"-        when (i == 2) stop-        appendBytes "after stop"--stopTest :: Test-stopTest = testGroup "stop" $ map ($ stopApp)-    [ testReq "GET /a/0" . assertPlain200 "even\nafter stop"-    , testReq "GET /a/1" . assertPlain200 "one\nodd\nafter stop"-    , testReq "GET /a/2" . assertPlain200 "even\n"-    , testReq "GET /a/3" . assertPlain200 "odd\nafter stop"-    ]------------------------------------------------------------------------------------acceptApp :: Application-acceptApp = runApp $ [capture|/|] $ do-    accept "application/json" . action $ bytes "json"-    accept "text/html;prm=t"  . action $ bytes "html+prm"-    accept "text/html"        . action $ bytes "html"-    action                             $ bytes "other"--acceptTest :: Test-acceptTest = testGroup "accept" $ map ($ acceptApp)-    [ testReq "GET / application/json" . (\a r -> assertJson200 "json"     a $ addA "application/json" r)-    , testReq "GET / text/html"        . (\a r -> assertHtml200 "html"     a $ addA "text/html"     r)-    , testReq "GET / text/html;p=a"    . (\a r -> assertHtml200 "html"     a $ addA "text/html;p=a" r)-    , testReq "GET / text/html;prm=t"  . (\a r -> assertHtml200 "html+prm" a $ addA "text/html;prm=t" r)-    , testReq "GET / text/plain"       . (\a r -> assertRequest 200 Nothing "other" a $ addA "text/plain" r)-    , testReq "GET / text/*"           . (\a r -> assertHtml200 "html"     a $ addA "text/*" r)-    , testReq "GET / text/*;p=a"       . (\a r -> assertHtml200 "html"     a $ addA "text/*;p=a" r)-    , testReq "GET / */*"              . (\a r -> assertJson200 "json"     a $ addA "*/*" r)-    , testReq "GET /"                  . assertRequest 200 Nothing "other"-    ]-  where-    addA :: S.ByteString -> Request -> Request-    addA ct r = r {requestHeaders = ("Accept", ct) : filter (("Accept" ==) . fst) (requestHeaders r)}------------------------------------------------------------------------------------multipleFilter1App :: Application-multipleFilter1App = runApp $ do-    root $ do-        method GET  . action $ contentType "text/plain" >> bytes "GET /"-        method POST . action $ contentType "text/html"  >> bytes "POST /"--    method DELETE . action   $ contentType "text/plain" >> bytes "DELETE ANY"--multipleFilter1Test :: Test-multipleFilter1Test = testGroup "multiple test1: root, method"-    [ testReq "GET /index.html" $ assertPlain200 "GET /"      multipleFilter1App-    , testReq "POST /"          $ assertHtml200 "POST /"      multipleFilter1App-    , testReq "DELETE /"        $ assertPlain200 "DELETE ANY" multipleFilter1App -    , testReq "PUT /"           $ assert404 multipleFilter1App-    ]------------------------------------------------------------------------------------applicationTests :: Test-applicationTests = testGroup "Application"-    [ helloWorldAllTest-    , methodFilterTest-    , httpVersionTest-    , rootFilterTest-    , restFilterTest-    , captureTest-    , queryTest-    , stopTest-    , acceptTest-    , multipleFilter1Test-    ]-

@@ -1,50 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Method where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--import Data.Apiary.Method-import qualified Data.ByteString as S--stdMethods :: [S.ByteString]-stdMethods =-    [ "GET"-    , "POST"-    , "HEAD"-    , "PUT"-    , "DELETE"-    , "TRACE"-    , "CONNECT"-    , "OPTIONS"-    , "PATCH"-    ]--methodTests :: Test-methodTests = testGroup "Method"-    [ testCase "renderMethod . parseMethod == id" $-        mapM_ (\s -> -            let s' = (renderMethod . parseMethod) s-            in assertBool (show s ++ " /= " ++ show s') $ s == s'-        ) ("YAMADA" : "neko" : "POSTa" : "DELET" : "CONNECt" : stdMethods)--    , testCase "parseMethod" $ do-        let assertMethod s t = assertBool (show s) $ parseMethod s == t-            assertNS s = assertMethod s (NonStandard s)-        assertMethod "GET"     GET-        assertMethod "POST"    POST-        assertMethod "HEAD"    HEAD-        assertMethod "PUT"     PUT-        assertMethod "DELETE"  DELETE-        assertMethod "TRACE"   TRACE-        assertMethod "CONNECT" CONNECT-        assertMethod "OPTIONS" OPTIONS-        assertMethod "PATCH"   PATCH-        assertNS "YAMADA"-        assertNS "neko"-        assertNS "POSTa"-        assertNS "DELET"-        assertNS "CONNECt"--    ]

@@ -1,12 +0,0 @@--import Test.Framework--import Application-import Method--main :: IO ()-main = defaultMain-    [ methodTests-    , applicationTests-    ]-

@@ -0,0 +1,340 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE DataKinds #-}++module Application(test) where++import Test.Framework(Test, testGroup)+import Test.Framework.Providers.HUnit(testCase)++import Control.Monad(when)+import Control.Monad.Identity(Identity(..))++import Web.Apiary+import Network.Wai(Request)+import qualified Network.Wai.Test as WT+import qualified Network.Wai as Wai+import qualified Network.HTTP.Types as HTTP++import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as S++testReq :: String -> (Request -> IO ()) -> Test+testReq str f = +    let (meth, other) = break (== ' ') str+        (p,  version) = break (== ' ') (tail other)+    in testCase str $ f (WT.setPath (setVersion version $ (WT.defaultRequest { Wai.requestMethod = S.pack meth })) (S.pack p))+  where+    setVersion [] r = r+    setVersion v r | v == " HTTP/1.0" = r { Wai.httpVersion = HTTP.http10 }+                   | v == " HTTP/0.9" = r { Wai.httpVersion = HTTP.http09 }+                   | otherwise        = r { Wai.httpVersion = HTTP.http11 }+--------------------------------------------------------------------------------++assertRequest :: Int -> (Maybe S.ByteString) -> L.ByteString -> Application -> Request -> IO ()+assertRequest sc ct body app req = flip WT.runSession app $ do+    res <- WT.request req+    WT.assertBody body res+    WT.assertStatus sc res+    maybe (return ()) (flip WT.assertContentType res) ct++assertPlain200 :: L.ByteString -> Application -> Request -> IO ()+assertPlain200 = assertRequest 200 (Just "text/plain")++assertHtml200 :: L.ByteString -> Application -> Request -> IO ()+assertHtml200 = assertRequest 200 (Just "text/html")++assertJson200 :: L.ByteString -> Application -> Request -> IO ()+assertJson200 = assertRequest 200 (Just "application/json")++assert404 :: Application -> Request -> IO ()+assert404 = assertRequest 404 (Just "text/plain") "404 Page Notfound.\n"++--------------------------------------------------------------------------------+runApp :: ApiaryT '[] '[] IO Identity () -> Application+runApp = runIdentity . runApiary return def+--------------------------------------------------------------------------------++helloWorldApp :: Application+helloWorldApp = runApp $ action $ do+    contentType "text/plain"+    bytes "hello"++helloWorldAllTest :: Test+helloWorldAllTest = testGroup "helloWorld" $ map ($ helloWorldApp)+    [ testReq "GET /"    . assertPlain200 "hello"+    , testReq "GET /foo" . assert404+    , testReq "POST /"   . assertPlain200 "hello"+    ]++--------------------------------------------------------------------------------++methodFilterApp :: Application+methodFilterApp = runApp $ do+    method "GET" . action $ contentType "text/plain" >> bytes "GET"+    method POST  . action $ contentType "text/plain" >> bytes "POST"++methodFilterTest :: Test+methodFilterTest = testGroup "methodFilter" $ map ($methodFilterApp)+    [ testReq "GET /"    . assertPlain200 "GET"+    , testReq "POST /"   . assertPlain200 "POST"+    , testReq "GET /foo" . assert404+    , testReq "DELETE /" . assert404+    ]++--------------------------------------------------------------------------------++httpVersionApp :: Application+httpVersionApp = runApp $ do+    http09 . action $ contentType "text/plain" >> bytes "09"+    http10 . action $ contentType "text/plain" >> bytes "10"+    http11 . action $ contentType "text/plain" >> bytes "11"++httpVersionTest :: Test+httpVersionTest = testGroup "httpVersionFilter" $ map ($ httpVersionApp)+    [ testReq "GET / HTTP/0.9" . assertPlain200 "09"+    , testReq "GET / HTTP/1.0" . assertPlain200 "10"+    , testReq "GET / HTTP/1.1" . assertPlain200 "11"+    ]++--------------------------------------------------------------------------------++rootFilterApp :: Application+rootFilterApp = runApp . root . action $ do+    contentType "text/html"+    bytes "root"++rootFilterTest :: Test+rootFilterTest = testGroup "rootFilter" $ map ($ rootFilterApp)+    [ testReq "GET /"           . assertHtml200 "root"+    , testReq "POST /"          . assertHtml200 "root"+    , testReq "GET /neko"       . assert404+    , testReq "GET /index.html" . assertHtml200 "root"+    ]++--------------------------------------------------------------------------------++restFilterApp :: Application+restFilterApp = runApp $ do+    [capture|/test/**rest|] . action $ contentType "text/plain" >> param [key|rest|] >>= showing+    [capture|/test/neko|] . action $ contentType "text/plain" >> bytes "nyan"++restFilterTest :: Test+restFilterTest = testGroup "rest capture" $ map ($ restFilterApp)+    [ testReq "GET /" . assert404+    , testReq "GET /test" . assertPlain200 "[]"+    , testReq "GET /test/foo" . assertPlain200 "[\"foo\"]"+    , testReq "GET /test/foo/bar" . assertPlain200 "[\"foo\",\"bar\"]"+    , testReq "GET /test/neko" . assertPlain200 "nyan"+    ]++--------------------------------------------------------------------------------++captureApp :: Application+captureApp = runApp $ do+    [capture|/foo|]  . action $ contentType "text/plain" >> bytes "foo"+    [capture|/int::Int|] . method GET . action $ contentType "text/plain" >> bytes "Int " >> param [key|int|] >>= appendShowing+    [capture|/d::Double|] . action $ contentType "text/plain" >> bytes "Double " >> param [key|d|] >>= appendShowing+    [capture|/bar/s::L.ByteString/i::Int|] . action $ contentType "text/plain" >> param [key|s|] >>= lazyBytes >> appendChar ' ' >> param [key|i|] >>= appendShowing+    [capture|/s::L.ByteString|] . action $ contentType "text/plain" >> bytes "fall " >> param [key|s|] >>= appendLazyBytes++captureTest :: Test+captureTest = testGroup "capture" $ map ($ captureApp)+    [ testReq "GET /foo"  . assertPlain200 "foo"+    , testReq "GET /12"   . assertPlain200 "Int 12"+    , testReq "GET /12.4" . assertPlain200 "Double 12.4"+    , testReq "POST /12"  . assertPlain200 "Double 12.0"+    , testReq "GET /bar"  . assertPlain200 "fall bar"+    , testReq "GET /baz"  . assertPlain200 "fall baz"+    , testReq "GET /bar/nyan/12"       . assertPlain200 "nyan 12"+    , testReq "GET /bar/nyan/12/other" . assert404+    ]++--------------------------------------------------------------------------------++queryApp f g h = runApp $ do+    _ <- (f [key|foo|] pInt)    . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing+    _ <- (g [key|foo|] pString) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing+    (h [key|foo|] (pMaybe pString)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing++queryOptionalApp :: Application+queryOptionalApp = runApp $ do+    ([key|foo|] =?!: (5 :: Int))                   . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing+    ([key|foo|] =?!: ("bar" :: String))            . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing+    ([key|foo|] =?!: (Just "baz" :: Maybe String)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing++queryFirstTest :: Test+queryFirstTest = testGroup "First" $ map ($ queryApp (=:) (=:) (=:))+    [ testReq "GET /" . assert404+    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing"+    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Nothing"+    , 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 Int 12"+    ]++queryOneTest :: Test+queryOneTest = testGroup "One" $ map ($ queryApp (=!:) (=!:) (=!:))+    [ testReq "GET /" . assert404+    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing"+    , testReq "GET /?foo&foo=3" . assert404+    , testReq "GET /?foo=12" . assertPlain200 "foo Int 12"+    , testReq "GET /?foo=a" . assertPlain200 "foo String \"a\""+    , testReq "GET /?foo=12&foo=23" . assert404+    , testReq "GET /?foo=12&foo=b" . assert404+    ]++queryOptionTest :: Test+queryOptionTest = testGroup "Option" $ map ($ queryApp (=?:) (=?:) (=?:))+    [ testReq "GET /" . assertPlain200 "foo Int Nothing"+    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Just Nothing"+    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Just Nothing"+    , 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 Int Just 12"+    ]++queryOptionalTest :: Test+queryOptionalTest = testGroup "Optional" $ map ($ queryOptionalApp)+    [ testReq "GET /" . assertPlain200 "foo Int 5"+    , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing"+    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Nothing"+    , 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 Int 12"+    ]++queryManyTest :: Test+queryManyTest = testGroup "Many" $ map ($ queryApp (=*:) (=*:) (=*:))+    [ testReq "GET /" . assertPlain200 "foo Int []"+    , testReq "GET /?foo" . assertPlain200 "foo Maybe String [Nothing]"+    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String [Nothing,Just \"3\"]"+    , 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,23]"+    , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String [\"12\",\"b\"]"+    ]++querySomeTest :: Test+querySomeTest = testGroup "Some" $ map ($ queryApp (=+:) (=+:) (=+:))+    [ testReq "GET /" . assert404+    , testReq "GET /?foo" . assertPlain200 "foo Maybe String [Nothing]"+    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String [Nothing,Just \"3\"]"+    , 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,23]"+    , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String [\"12\",\"b\"]"+    ]++switchQueryApp :: Application+switchQueryApp = runApp $ do+    switchQuery [key|foo|] . switchQuery [key|bar|] . action $ do+        contentType "text/plain"+        param [key|foo|] >>= showing+        param [key|bar|] >>= appendShowing++switchQueryTest :: Test+switchQueryTest = testGroup "switch" $ map ($ switchQueryApp)+    [ testReq "GET /"                    . assertPlain200 "FalseFalse"+    , testReq "GET /?foo"                . assertPlain200 "TrueFalse"+    , testReq "GET /?foo&bar"            . assertPlain200 "TrueTrue"+    , testReq "GET /?foo=true"           . assertPlain200 "TrueFalse"+    , testReq "GET /?foo=false"          . assertPlain200 "FalseFalse"+    , testReq "GET /?foo=false&bar=true" . assertPlain200 "FalseTrue"+    , testReq "GET /?foo&bar=true"       . assertPlain200 "TrueTrue"+    , testReq "GET /?foo=1&bar=0"        . assertPlain200 "TrueFalse"+    ]++queryTest :: Test+queryTest = testGroup "query"+    [ queryFirstTest+    , queryOneTest+    , queryOptionTest+    , queryOptionalTest+    , queryManyTest+    , querySomeTest+    , switchQueryTest+    ]++--------------------------------------------------------------------------------+stopApp :: Application+stopApp = runApp $ 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 appendBytes "even\n" else appendBytes "odd\n"+        when (i == 2) stop+        appendBytes "after stop"++stopTest :: Test+stopTest = testGroup "stop" $ map ($ stopApp)+    [ testReq "GET /a/0" . assertPlain200 "even\nafter stop"+    , testReq "GET /a/1" . assertPlain200 "one\nodd\nafter stop"+    , testReq "GET /a/2" . assertPlain200 "even\n"+    , testReq "GET /a/3" . assertPlain200 "odd\nafter stop"+    ]++--------------------------------------------------------------------------------++acceptApp :: Application+acceptApp = runApp $ [capture|/|] $ do+    accept "application/json" . action $ bytes "json"+    accept "text/html;prm=t"  . action $ bytes "html+prm"+    accept "text/html"        . action $ bytes "html"+    action                             $ bytes "other"++acceptTest :: Test+acceptTest = testGroup "accept" $ map ($ acceptApp)+    [ testReq "GET / application/json" . (\a r -> assertJson200 "json"     a $ addA "application/json" r)+    , testReq "GET / text/html"        . (\a r -> assertHtml200 "html"     a $ addA "text/html"     r)+    , testReq "GET / text/html;p=a"    . (\a r -> assertHtml200 "html"     a $ addA "text/html;p=a" r)+    , testReq "GET / text/html;prm=t"  . (\a r -> assertHtml200 "html+prm" a $ addA "text/html;prm=t" r)+    , testReq "GET / text/plain"       . (\a r -> assertRequest 200 Nothing "other" a $ addA "text/plain" r)+    , testReq "GET / text/*"           . (\a r -> assertHtml200 "html"     a $ addA "text/*" r)+    , testReq "GET / text/*;p=a"       . (\a r -> assertHtml200 "html"     a $ addA "text/*;p=a" r)+    , testReq "GET / */*"              . (\a r -> assertJson200 "json"     a $ addA "*/*" r)+    , testReq "GET /"                  . assertRequest 200 Nothing "other"+    ]+  where+    addA :: S.ByteString -> Request -> Request+    addA ct r = r {Wai.requestHeaders = ("Accept", ct) : filter (("Accept" ==) . fst) (Wai.requestHeaders r)}++--------------------------------------------------------------------------------++multipleFilter1App :: Application+multipleFilter1App = runApp $ do+    root $ do+        method GET  . action $ contentType "text/plain" >> bytes "GET /"+        method POST . action $ contentType "text/html"  >> bytes "POST /"++    method DELETE . action   $ contentType "text/plain" >> bytes "DELETE ANY"++multipleFilter1Test :: Test+multipleFilter1Test = testGroup "multiple test1: root, method"+    [ testReq "GET /index.html" $ assertPlain200 "GET /"      multipleFilter1App+    , testReq "POST /"          $ assertHtml200 "POST /"      multipleFilter1App+    , testReq "DELETE /"        $ assertPlain200 "DELETE ANY" multipleFilter1App +    , testReq "PUT /"           $ assert404 multipleFilter1App+    ]++--------------------------------------------------------------------------------++test :: Test+test = testGroup "Application"+    [ helloWorldAllTest+    , methodFilterTest+    , httpVersionTest+    , rootFilterTest+    , restFilterTest+    , captureTest+    , queryTest+    , stopTest+    , acceptTest+    , multipleFilter1Test+    ]+

@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+module Method(test) where++import Test.Framework(Test, testGroup)+import Test.Framework.Providers.HUnit(testCase)+import Test.HUnit(assertBool)++import Data.Apiary.Method+import qualified Data.ByteString as S++stdMethods :: [S.ByteString]+stdMethods =+    [ "GET"+    , "POST"+    , "HEAD"+    , "PUT"+    , "DELETE"+    , "TRACE"+    , "CONNECT"+    , "OPTIONS"+    , "PATCH"+    ]++test :: Test+test = testGroup "Method"+    [ testCase "renderMethod . parseMethod == id" $+        mapM_ (\s -> +            let s' = (renderMethod . parseMethod) s+            in assertBool (show s ++ " /= " ++ show s') $ s == s'+        ) ("YAMADA" : "neko" : "POSTa" : "DELET" : "CONNECt" : stdMethods)++    , testCase "parseMethod" $ do+        let assertMethod s t = assertBool (show s) $ parseMethod s == t+            assertNS s = assertMethod s (NonStandard s)+        assertMethod "GET"     GET+        assertMethod "POST"    POST+        assertMethod "HEAD"    HEAD+        assertMethod "PUT"     PUT+        assertMethod "DELETE"  DELETE+        assertMethod "TRACE"   TRACE+        assertMethod "CONNECT" CONNECT+        assertMethod "OPTIONS" OPTIONS+        assertMethod "PATCH"   PATCH+        assertNS "YAMADA"+        assertNS "neko"+        assertNS "POSTa"+        assertNS "DELET"+        assertNS "CONNECt"+    ]

@@ -0,0 +1,11 @@++import Test.Framework++import qualified Application+import qualified Method++main :: IO ()+main = defaultMain+    [ Application.test+    , Method.test+    ]