diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +# 1.3.0 +* new router(web-routing package) +* new dictionary + + insert -\> add + NotMember -\> (\ focus + focus -\> [delete] + +* change boolean query behaviour + + old: ?key == fail + new: ?key == true + # 1.2.3 * fix haddock documentation. diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -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 diff --git a/src/Control/Monad/Apiary/Action.hs b/src/Control/Monad/Apiary/Action.hs --- a/src/Control/Monad/Apiary/Action.hs +++ b/src/Control/Monad/Apiary/Action.hs @@ -39,6 +39,7 @@ -- * not export from Web.Apiary , ContentType , stopWith + , applyDict -- ** getter , getRequest , getHeaders diff --git a/src/Control/Monad/Apiary/Action/Internal.hs b/src/Control/Monad/Apiary/Action/Internal.hs --- a/src/Control/Monad/Apiary/Action/Internal.hs +++ b/src/Control/Monad/Apiary/Action/Internal.hs @@ -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 diff --git a/src/Control/Monad/Apiary/Filter.hs b/src/Control/Monad/Apiary/Filter.hs --- a/src/Control/Monad/Apiary/Filter.hs +++ b/src/Control/Monad/Apiary/Filter.hs @@ -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 ( 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 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 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 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 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 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 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 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 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 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)]) diff --git a/src/Control/Monad/Apiary/Filter/Capture.hs b/src/Control/Monad/Apiary/Filter/Capture.hs --- a/src/Control/Monad/Apiary/Filter/Capture.hs +++ b/src/Control/Monad/Apiary/Filter/Capture.hs @@ -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. 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. 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. 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) diff --git a/src/Control/Monad/Apiary/Filter/Internal.hs b/src/Control/Monad/Apiary/Filter/Internal.hs --- a/src/Control/Monad/Apiary/Filter/Internal.hs +++ b/src/Control/Monad/Apiary/Filter/Internal.hs @@ -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 ( (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 (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 diff --git a/src/Control/Monad/Apiary/Filter/Internal/Capture.hs b/src/Control/Monad/Apiary/Filter/Internal/Capture.hs deleted file mode 100644 --- a/src/Control/Monad/Apiary/Filter/Internal/Capture.hs +++ /dev/null @@ -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 = []}) diff --git a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs --- a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +++ b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs @@ -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 diff --git a/src/Control/Monad/Apiary/Internal.hs b/src/Control/Monad/Apiary/Internal.hs --- a/src/Control/Monad/Apiary/Internal.hs +++ b/src/Control/Monad/Apiary/Internal.hs @@ -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 diff --git a/src/Data/Apiary/Compat.hs b/src/Data/Apiary/Compat.hs --- a/src/Data/Apiary/Compat.hs +++ b/src/Data/Apiary/Compat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE KindSignatures #-} diff --git a/src/Data/Apiary/Dict.hs b/src/Data/Apiary/Dict.hs deleted file mode 100644 --- a/src/Data/Apiary/Dict.hs +++ /dev/null @@ -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 - -- > :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 --- > --- > :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." - } diff --git a/src/Data/Apiary/Param.hs b/src/Data/Apiary/Param.hs --- a/src/Data/Apiary/Param.hs +++ b/src/Data/Apiary/Param.hs @@ -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 ( *) 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 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 diff --git a/src/Network/Wai/Parse.hs b/src/Network/Wai/Parse.hs --- a/src/Network/Wai/Parse.hs +++ b/src/Network/Wai/Parse.hs @@ -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) diff --git a/src/Web/Apiary.hs b/src/Web/Apiary.hs --- a/src/Web/Apiary.hs +++ b/src/Web/Apiary.hs @@ -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 (=>)) import Network.Wai(FilePart(..), Application) import Text.Blaze.Html(Html) +import Web.Apiary.TH(key) diff --git a/src/Web/Apiary/TH.hs b/src/Web/Apiary/TH.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/TH.hs @@ -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." + } diff --git a/test/Application.hs b/test/Application.hs deleted file mode 100644 --- a/test/Application.hs +++ /dev/null @@ -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 - ] - diff --git a/test/Method.hs b/test/Method.hs deleted file mode 100644 --- a/test/Method.hs +++ /dev/null @@ -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" - - ] diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,12 +0,0 @@ - -import Test.Framework - -import Application -import Method - -main :: IO () -main = defaultMain - [ methodTests - , applicationTests - ] - diff --git a/tests/Application.hs b/tests/Application.hs new file mode 100644 --- /dev/null +++ b/tests/Application.hs @@ -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 + ] + diff --git a/tests/Method.hs b/tests/Method.hs new file mode 100644 --- /dev/null +++ b/tests/Method.hs @@ -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" + ] diff --git a/tests/main.hs b/tests/main.hs new file mode 100644 --- /dev/null +++ b/tests/main.hs @@ -0,0 +1,11 @@ + +import Test.Framework + +import qualified Application +import qualified Method + +main :: IO () +main = defaultMain + [ Application.test + , Method.test + ]