apiary 0.15.2 → 0.16.0

raw patch · 19 files changed

+912/−599 lines, 19 filesdep +HUnitdep +timedep +transformersdep −reflectionPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, time, transformers

Dependencies removed: reflection

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• apiary.cabal +22/−13
• src/Control/Monad/Apiary.hs +6/−2
• src/Control/Monad/Apiary/Action.hs +1/−0
• src/Control/Monad/Apiary/Action/Internal.hs +76/−70
• src/Control/Monad/Apiary/Filter.hs +80/−61
• src/Control/Monad/Apiary/Filter/Internal.hs +11/−8
• src/Control/Monad/Apiary/Filter/Internal/Capture.hs +5/−4
• src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +2/−1
• src/Control/Monad/Apiary/Filter/Internal/Strategy.hs +61/−47
• src/Control/Monad/Apiary/Internal.hs +88/−68
• src/Data/Apiary/Extension.hs +34/−0
• src/Data/Apiary/Extension/Internal.hs +26/−0
• src/Data/Apiary/Param.hs +79/−34
• src/Data/Apiary/SList.hs +15/−17
• src/Web/Apiary.hs +19/−8
• test/Application.hs +324/−0
• test/Method.hs +50/−0
• test/main.hs +5/−266

@@ -1,3 +1,11 @@+# 0.16.0+* new Extension API.+* add middleware function.+* remove Typeable restriction from Path/Query class.+* add Optional strategy, (=?!:) query fetcher.+* add accept filter.+* add Path/Query instances to Day.+ # 0.15.2 * you can set status and response headers anywhere. * deprecate lbs.

@@ -1,5 +1,5 @@ name:                apiary-version:             0.15.2+version:             0.16.0 synopsis:            Simple and type safe web framework that can be automatically generate API documentation. description:   Simple and type safe web framework that can be automatically generate API documentation.@@ -13,7 +13,7 @@   import qualified Data.ByteString.Lazy.Char8 as L   .   main :: IO ()-  main = run 3000 . runApiary def $ do+  main = server (run 3000) . runApiary def $ do   &#32;&#32;[capture|/:Int|] . (&#34;name&#34; =: pLazyByteString) . method GET . action $ \\age name -> do   &#32;&#32;&#32;&#32;&#32;&#32;guard (age >= 18)   &#32;&#32;&#32;&#32;&#32;&#32;contentType &#34;text/html&#34;@@ -31,15 +31,15 @@   404 Page Notfound.   @   .-    * High performance(benchmark: <https://github.com/philopon/apiary/blob/v0.15.2/bench>).+    * High performance(benchmark: <https://github.com/philopon/apiary-benchmark/tree/v0.16.0>).   .     * Nestable route handling(Apiary Monad; capture, method and more.).   .     * Type safe route filter.   .-    * Auto generate API documentation(example: <https://github.com/philopon/apiary/blob/v0.15.2/examples/api.hs>, <https://rawgit.com/philopon/apiary/v0.15.2/examples/api.html>).+    * Auto generate API documentation(example: <https://github.com/philopon/apiary/blob/v0.16.0/examples/api.hs>, <https://rawgit.com/philopon/apiary/v0.16.0/examples/api.html>).   .-  more examples: <https://github.com/philopon/apiary/blob/v0.15.2/examples/>+  more examples: <https://github.com/philopon/apiary/blob/v0.16.0/examples/>  license:             MIT license-file:        LICENSE@@ -74,6 +74,8 @@                        Control.Monad.Apiary.Filter.Internal.Strategy                        Control.Monad.Apiary.Action +                       Data.Apiary.Extension+                       Data.Apiary.Extension.Internal                        Data.Apiary.SList                        Data.Apiary.Param                        Data.Apiary.Method@@ -88,25 +90,28 @@                        Web.Apiary.TH   build-depends:       base                 >=4.6   && <4.8                      , template-haskell     >=2.8   && <2.10++                     , transformers         >=0.2   && <0.5+                     , transformers-base    >=0.4   && <0.5                      , mtl                  >=2.1   && <2.3                      , monad-control        >=0.3   && <0.4-                     , transformers-base    >=0.4   && <0.5+                     , exceptions           >=0.6   && <0.7 +                     , http-types           >=0.8   && <0.9+                     , mime-types           >=0.1   && <0.2+                      , text                 >=1.1   && <1.2                      , bytestring           >=0.10  && <0.11+                     , bytestring-lexing    >=0.4   && <0.5                      , blaze-builder        >=0.3   && <0.4-                     , data-default-class   >=0.0   && <0.1-                     , reflection           >=1.4   && <1.6--                     , http-types           >=0.8   && <0.9-                     , mime-types           >=0.1   && <0.2-                     , exceptions           >=0.6   && <0.7                      , blaze-html           >=0.7   && <0.8                      , blaze-markup         >=0.6   && <0.7                      , case-insensitive     >=1.1   && <1.3++                     , data-default-class   >=0.0   && <0.1                      , unordered-containers >=0.2   && <0.3                      , hashable             >=1.1   && <1.3-                     , bytestring-lexing    >=0.4   && <0.5+                     , time                 >=1.4   && <1.5    if impl(ghc < 7.8)     build-depends:     tagged               >=0.7   && <0.8@@ -127,13 +132,17 @@  test-suite test-framework   main-is:             main.hs+  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                      , apiary                      , bytestring           >=0.10  && <0.11                      , http-types           >=0.8   && <0.9+                     , HUnit                >=1.2   && <1.3   if flag(wai3)     build-depends:     wai                  >=3.0   && <3.1                      , wai-extra            >=3.0   && <3.1

@@ -1,11 +1,15 @@ module Control.Monad.Apiary-    ( ApiaryT, Apiary+    ( ApiaryT, server+    , runApiaryTWith+    , runApiaryWith     , runApiary-    , runApiaryT     -- * getter     , apiaryConfig+    , apiaryExt     -- * execute action     , action, action'+    -- * middleware+    , middleware     -- * API documentation     , group     , document

@@ -14,6 +14,7 @@     , getReqParams     , File(..)     , getReqFiles+    , getExt      -- ** setter     , status

@@ -12,6 +12,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}  module Control.Monad.Apiary.Action.Internal where @@ -23,12 +24,13 @@ import Control.Monad.Catch import Control.Monad.Trans.Control -import Network.Mime+import Network.Mime hiding (Extension) import Network.HTTP.Types import Network.Wai import qualified Network.Wai.Parse as P -import Data.Monoid+import Data.Monoid hiding (All)+import Data.Apiary.Extension import Data.Apiary.Param import Data.Apiary.Document import Data.Apiary.Document.Html@@ -63,7 +65,7 @@     , mimeType            :: FilePath -> S.ByteString     } -defaultDocumentationAction :: Monad m => DefaultDocumentConfig -> ActionT m ()+defaultDocumentationAction :: Monad m => DefaultDocumentConfig -> ActionT exts m () defaultDocumentationAction conf = do     d <- getDocuments     contentType "text/html"@@ -134,10 +136,11 @@  -------------------------------------------------------------------------------- -data ActionEnv = ActionEnv+data ActionEnv exts = ActionEnv     { actionConfig    :: ApiaryConfig     , actionRequest   :: Request     , actionDocuments :: Documents+    , actionExts      :: Extensions exts     }  data Action a @@ -145,23 +148,23 @@     | Pass     | Stop Response -newtype ActionT m a = ActionT { unActionT :: forall b. -    ActionEnv+newtype ActionT exts m a = ActionT { unActionT :: forall b. +    ActionEnv exts     -> ActionState     -> (a -> ActionState -> m (Action b))     -> m (Action b)     } -runActionT :: Monad m => ActionT m a-           -> ActionEnv -> ActionState+runActionT :: Monad m => ActionT exts m a+           -> ActionEnv exts -> ActionState            -> m (Action a) runActionT m env st = unActionT m env st $ \a !st' ->     return (Continue st' a) {-# INLINE runActionT #-}  actionT :: Monad m -        => (ActionEnv -> ActionState -> m (Action a))-        -> ActionT m a+        => (ActionEnv exts -> ActionState -> m (Action a))+        -> ActionT exts m a actionT f = ActionT $ \env !st cont -> f env st >>= \case     Pass            -> return Pass     Stop s          -> return $ Stop s@@ -170,17 +173,17 @@  -- | n must be Monad, so cant be MFunctor. hoistActionT :: (Monad m, Monad n)-             => (forall b. m b -> n b) -> ActionT m a -> ActionT n a+             => (forall b. m b -> n b) -> ActionT exts m a -> ActionT exts n a hoistActionT run m = actionT $ \e s -> run (runActionT m e s) {-# INLINE hoistActionT #-} -execActionT :: ApiaryConfig -> Documents -> ActionT IO () -> Application+execActionT :: ApiaryConfig -> Extensions exts -> Documents -> ActionT exts IO () -> Application #ifdef WAI3-execActionT config doc m request send = +execActionT config exts doc m request send =  #else-execActionT config doc m request = let send = return in+execActionT config exts doc m request = let send = return in #endif-    runActionT m (ActionEnv config request doc) (initialState config) >>= \case+    runActionT m (ActionEnv config request doc exts) (initialState config) >>= \case #ifdef WAI3         Pass         -> notFound config request send #else@@ -191,18 +194,18 @@  -------------------------------------------------------------------------------- -instance Functor (ActionT m) where+instance Functor (ActionT exts m) where     fmap f m = ActionT $ \env st cont ->         unActionT m env st (\a !s' -> cont (f a) s') -instance Applicative (ActionT m) where+instance Applicative (ActionT exts m) where     pure x = ActionT $ \_ !st cont -> cont x st     mf <*> ma = ActionT $ \env st cont ->         unActionT mf env st  $ \f !st'  ->         unActionT ma env st' $ \a !st'' ->         cont (f a) st'' -instance Monad m => Monad (ActionT m) where+instance Monad m => Monad (ActionT exts m) where     return x = ActionT $ \_ !st cont -> cont x st     m >>= k  = ActionT $ \env !st cont ->         unActionT m env st $ \a !st' ->@@ -210,24 +213,24 @@     fail s = ActionT $ \(ActionEnv{actionConfig = c}) _ _ -> return $         Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s) -instance MonadIO m => MonadIO (ActionT m) where+instance MonadIO m => MonadIO (ActionT exts m) where     liftIO m = ActionT $ \_ !st cont ->         liftIO m >>= \a -> cont a st -instance MonadTrans ActionT where+instance MonadTrans (ActionT exts) where     lift m = ActionT $ \_ !st cont ->         m >>= \a -> cont a st -instance MonadThrow m => MonadThrow (ActionT m) where+instance MonadThrow m => MonadThrow (ActionT exts m) where     throwM e = ActionT $ \_ !st cont ->         throwM e >>= \a -> cont a st -instance MonadCatch m => MonadCatch (ActionT m) where+instance MonadCatch m => MonadCatch (ActionT exts m) where     catch m h = ActionT $ \env !st cont ->         catch (unActionT m env st cont) (\e -> unActionT (h e) env st cont)     {-# INLINE catch #-} -instance MonadMask m => MonadMask (ActionT m) where+instance MonadMask m => MonadMask (ActionT exts m) where     mask a = ActionT $ \env !st cont ->         mask $ \u -> unActionT (a $ q u) env st cont       where@@ -239,13 +242,13 @@     {-# INLINE mask #-}     {-# INLINE uninterruptibleMask #-} -instance (Monad m, Functor m) => Alternative (ActionT m) where+instance (Monad m, Functor m) => Alternative (ActionT exts m) where     empty = mzero     (<|>) = mplus     {-# INLINE empty #-}     {-# INLINE (<|>) #-} -instance Monad m => MonadPlus (ActionT m) where+instance Monad m => MonadPlus (ActionT exts m) where     mzero = ActionT $ \_ _ _ -> return Pass     mplus m n = ActionT $ \e !s cont -> unActionT m e s cont >>= \case         Continue !st a -> return $ Continue st a@@ -254,40 +257,43 @@     {-# INLINE mzero #-}     {-# INLINE mplus #-} -instance MonadBase b m => MonadBase b (ActionT m) where+instance MonadBase b m => MonadBase b (ActionT exts m) where     liftBase = liftBaseDefault -instance MonadTransControl ActionT where-    newtype StT ActionT a = StActionT { unStActionT :: Action a }+instance MonadTransControl (ActionT exts) where+    newtype StT (ActionT exts) a = StActionT { unStActionT :: Action a }     liftWith f = actionT $ \e !s ->          liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t e s)     restoreT m = actionT $ \_ _ -> liftM unStActionT m -instance MonadBaseControl b m => MonadBaseControl b (ActionT m) where-    newtype StM (ActionT m) a = StMT { unStMT :: ComposeSt ActionT m a }+instance MonadBaseControl b m => MonadBaseControl b (ActionT exts m) where+    newtype StM (ActionT exts m) a = StMT { unStMT :: ComposeSt (ActionT exts) m a }     liftBaseWith = defaultLiftBaseWith StMT     restoreM     = defaultRestoreM unStMT -instance MonadReader r m => MonadReader r (ActionT m) where+instance MonadReader r m => MonadReader r (ActionT exts m) where     ask     = lift ask     local f = hoistActionT $ local f  -------------------------------------------------------------------------------- -getEnv :: Monad m => ActionT m ActionEnv+getEnv :: Monad m => ActionT exts m (ActionEnv exts) getEnv = ActionT $ \e s c -> c e s  -- | get raw request. since 0.1.0.0.-getRequest :: Monad m => ActionT m Request+getRequest :: Monad m => ActionT exts m Request getRequest = liftM actionRequest getEnv -getConfig :: Monad m => ActionT m ApiaryConfig+getConfig :: Monad m => ActionT exts m ApiaryConfig getConfig = liftM actionConfig getEnv -getDocuments :: Monad m => ActionT m Documents+getExt :: (Has e exts, Monad m) => proxy e -> ActionT exts m e+getExt p = liftM (getExtension p . actionExts) getEnv++getDocuments :: Monad m => ActionT exts m Documents getDocuments = liftM actionDocuments getEnv -getRequestBody :: MonadIO m => ActionT m ([Param], [File])+getRequestBody :: MonadIO m => ActionT exts m ([Param], [File]) getRequestBody = ActionT $ \e s c -> case actionReqBody s of     Just b  -> c b s     Nothing -> do@@ -298,57 +304,57 @@     convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent  -- | parse request body and return params. since 0.9.0.0.-getReqParams :: MonadIO m => ActionT m [Param]+getReqParams :: MonadIO m => ActionT exts m [Param] getReqParams = fst <$> getRequestBody  -- | parse request body and return files. since 0.9.0.0.-getReqFiles :: MonadIO m => ActionT m [File]+getReqFiles :: MonadIO m => ActionT exts m [File] getReqFiles = snd <$> getRequestBody  -------------------------------------------------------------------------------- -modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m ()+modifyState :: Monad m => (ActionState -> ActionState) -> ActionT exts m () modifyState f = ActionT $ \_ s c -> c () (f s) -getState :: ActionT m ActionState+getState :: ActionT exts m ActionState getState = ActionT $ \_ s c -> c s s  -- | set status code. since 0.1.0.0.-status :: Monad m => Status -> ActionT m ()+status :: Monad m => Status -> ActionT exts m () status st = modifyState (\s -> s { actionStatus = st } )  -- | get all request headers. since 0.6.0.0.-getHeaders :: Monad m => ActionT m RequestHeaders+getHeaders :: Monad m => ActionT exts m RequestHeaders getHeaders = requestHeaders `liftM` getRequest  -- | modify response header. since 0.1.0.0.-modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT m ()+modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT exts m () modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } )  -- | add response header. since 0.1.0.0.-addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT m ()+addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT exts m () addHeader h v = modifyHeader ((h,v):)  -- | set response headers. since 0.1.0.0.-setHeaders :: Monad m => ResponseHeaders -> ActionT m ()+setHeaders :: Monad m => ResponseHeaders -> ActionT exts m () setHeaders hs = modifyHeader (const hs)  type ContentType = S.ByteString  -- | set content-type header. -- if content-type header already exists, replace it. since 0.1.0.0.-contentType :: Monad m => ContentType -> ActionT m ()+contentType :: Monad m => ContentType -> ActionT exts m () contentType c = modifyHeader     (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h)  --------------------------------------------------------------------------------  -- | stop handler and send current state. since 0.3.3.0.-stop :: Monad m => ActionT m a+stop :: Monad m => ActionT exts m a stop = ActionT $ \_ s _ -> return $ Stop (toResponse s)  -- | stop with response. since 0.4.2.0.-stopWith :: Monad m => Response -> ActionT m a+stopWith :: Monad m => Response -> ActionT exts m a stopWith a = ActionT $ \_ _ _ -> return $ Stop a  -- | redirect handler@@ -359,7 +365,7 @@ redirectWith :: Monad m              => Status              -> S.ByteString -- ^ Location redirect to-             -> ActionT m ()+             -> ActionT exts m () redirectWith st url = do     status st     addHeader "location" url@@ -374,7 +380,7 @@ -- 307                      TemporaryRedirect  -- | redirect with 301 Moved Permanently. since 0.3.3.0.-redirectPermanently :: Monad m => S.ByteString -> ActionT m ()+redirectPermanently :: Monad m => S.ByteString -> ActionT exts m () redirectPermanently = redirectWith movedPermanently301  -- | redirect with:@@ -383,7 +389,7 @@ -- 302 Moved Temporarily (Other) --  -- since 0.6.2.0.-redirect :: Monad m => S.ByteString -> ActionT m ()+redirect :: Monad m => S.ByteString -> ActionT exts m () redirect to = do     v <- httpVersion <$> getRequest     if v == http11@@ -396,7 +402,7 @@ -- 302 Moved Temporarily (Other) -- -- since 0.3.3.0.-redirectTemporary :: Monad m => S.ByteString -> ActionT m ()+redirectTemporary :: Monad m => S.ByteString -> ActionT exts m () redirectTemporary to = do     v <- httpVersion <$> getRequest     if v == http11@@ -408,78 +414,78 @@ -- example(use pipes-wai) -- -- @--- producer :: Monad m => Producer (Flush Builder) IO () -> ActionT m ()+-- producer :: Monad m => Producer (Flush Builder) IO () -> ActionT exts m () -- producer = response (\s h -> responseProducer s h) -- @ ---rawResponse :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT m ()+rawResponse :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT exts m () rawResponse f = modifyState (\s -> s { actionResponse = ResponseFunc f } )  -- | reset response body to no response. since v0.15.2.-reset :: Monad m => ActionT m ()+reset :: Monad m => ActionT exts m () reset = modifyState (\s -> s { actionResponse = mempty } )  -- | set response body file content, without set Content-Type. since 0.1.0.0.-file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()+file' :: Monad m => FilePath -> Maybe FilePart -> ActionT exts m () file' f p = modifyState (\s -> s { actionResponse = ResponseFile f p } )  -- | set response body file content and detect Content-Type by extension. since 0.1.0.0.-file :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()+file :: Monad m => FilePath -> Maybe FilePart -> ActionT exts m () file f p = do     mime <- mimeType <$> getConfig     contentType (mime f)     file' f p  -- | append response body from builder. since 0.1.0.0.-builder :: Monad m => Builder -> ActionT m ()+builder :: Monad m => Builder -> ActionT exts m () builder b = modifyState (\s -> s { actionResponse = actionResponse s <> ResponseBuilder b } )  -- | append response body from strict bytestring. since 0.15.2.-bytes :: Monad m => S.ByteString -> ActionT m ()+bytes :: Monad m => S.ByteString -> ActionT exts m () bytes = builder . B.fromByteString  -- | append response body from lazy bytestring. since 0.15.2.-lazyBytes :: Monad m => L.ByteString -> ActionT m ()+lazyBytes :: Monad m => L.ByteString -> ActionT exts m () lazyBytes = builder . B.fromLazyByteString  -- | append response body from strict text. encoding UTF-8. since 0.15.2.-text :: Monad m => T.Text -> ActionT m ()+text :: Monad m => T.Text -> ActionT exts m () text = builder . B.fromText  -- | append response body from lazy text. encoding UTF-8. since 0.15.2.-lazyText :: Monad m => TL.Text -> ActionT m ()+lazyText :: Monad m => TL.Text -> ActionT exts m () lazyText = builder . B.fromLazyText  -- | append response body from show. encoding UTF-8. since 0.15.2.-showing :: (Monad m, Show a) => a -> ActionT m ()+showing :: (Monad m, Show a) => a -> ActionT exts m () showing = builder . B.fromShow  -- | append response body from string. encoding UTF-8. since 0.15.2.-string :: Monad m => String -> ActionT m ()+string :: Monad m => String -> ActionT exts m () string = builder . B.fromString  -- | append response body from char. encoding UTF-8. since 0.15.2.-char :: Monad m => Char -> ActionT m ()+char :: Monad m => Char -> ActionT exts m () char = builder . B.fromChar  -- | set response body source. since 0.9.0.0.-stream :: Monad m => StreamingBody -> ActionT m ()+stream :: Monad m => StreamingBody -> ActionT exts m () stream str = modifyState (\s -> s { actionResponse = ResponseStream str })  {-# DEPRECATED source "use stream" #-}-source :: Monad m => StreamingBody -> ActionT m ()+source :: Monad m => StreamingBody -> ActionT exts m () source = stream  {-# DEPRECATED redirectFound, redirectSeeOther "use redirect" #-} -- | redirect with 302 Found. since 0.3.3.0.-redirectFound       :: Monad m => S.ByteString -> ActionT m ()+redirectFound       :: Monad m => S.ByteString -> ActionT exts m () redirectFound       = redirectWith found302  -- | redirect with 303 See Other. since 0.3.3.0.-redirectSeeOther    :: Monad m => S.ByteString -> ActionT m ()+redirectSeeOther    :: Monad m => S.ByteString -> ActionT exts m () redirectSeeOther    = redirectWith seeOther303  {-# DEPRECATED lbs "use lazyBytes" #-} -- | append response body from lazy bytestring. since 0.1.0.0.-lbs :: Monad m => L.ByteString -> ActionT m ()+lbs :: Monad m => L.ByteString -> ActionT exts m () lbs = lazyBytes

@@ -12,7 +12,7 @@ module Control.Monad.Apiary.Filter (     -- * filters     -- ** http method-      method, Method(..)+      method     -- ** http version     , Control.Monad.Apiary.Filter.httpVersion     , http09, http10, http11@@ -28,7 +28,7 @@     , QueryKey(..), (??)     , query     -- *** specified operators-    , (=:), (=!:), (=?:), (?:), (=*:), (=+:)+    , (=:), (=!:), (=?:), (=?!:), (?:), (=*:), (=+:)     , hasQuery      -- ** header matcher@@ -37,6 +37,7 @@     , headers     , header     , header'+    , accept      -- ** other     , ssl@@ -47,8 +48,10 @@     ) where  import Network.Wai as Wai+import Network.Wai.Parse import qualified Network.HTTP.Types as HT +import Control.Applicative import Control.Monad import Control.Monad.Trans @@ -62,12 +65,11 @@ import Text.Blaze.Html import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as SC+import qualified Data.Text.Encoding as T import Data.Monoid import Data.Proxy import Data.String-import Data.Reflection -import Data.Apiary.SList import Data.Apiary.Param import Data.Apiary.Document import Data.Apiary.Method@@ -78,40 +80,40 @@ -- method GET      -- stdmethod -- method \"HOGE\" -- non standard method -- @-method :: Monad n => Method -> ApiaryT c n m a -> ApiaryT c n m a+method :: Monad actM => Method -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () method m = focus' (DocMethod m) (Just m) id return  {-# DEPRECATED stdMethod "use method" #-} -- | filter by HTTP method using StdMethod. since 0.1.0.0.-stdMethod :: Monad n => Method -> ApiaryT c n m a -> ApiaryT c n m a+stdMethod :: Monad actM => Method -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () stdMethod = method  -- | filter by ssl accessed. since 0.1.0.0.-ssl :: Monad n => ApiaryT c n m a -> ApiaryT c n m a+ssl :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () ssl = function_ (DocPrecondition "SSL required") isSecure  -- | http version filter. since 0.5.0.0.-httpVersion :: Monad n => HT.HttpVersion -> Html -> ApiaryT c n m b -> ApiaryT c n m b+httpVersion :: Monad actM => HT.HttpVersion -> Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () httpVersion v h = function_ (DocPrecondition h) $ (v ==) . Wai.httpVersion  -- | http/0.9 only accepted fiter. since 0.5.0.0.-http09 :: Monad n => ApiaryT c n m b -> ApiaryT c n m b+http09 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () http09 = Control.Monad.Apiary.Filter.httpVersion HT.http09 "HTTP/0.9 only"  -- | http/1.0 only accepted fiter. since 0.5.0.0.-http10 :: Monad n => ApiaryT c n m b -> ApiaryT c n m b+http10 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () http10 = Control.Monad.Apiary.Filter.httpVersion HT.http10 "HTTP/1.0 only"  -- | http/1.1 only accepted fiter. since 0.5.0.0.-http11 :: Monad n => ApiaryT c n m b -> ApiaryT c n m b+http11 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () http11 = Control.Monad.Apiary.Filter.httpVersion HT.http11 "HTTP/1.1 only"  -- | filter by 'Control.Monad.Apiary.Action.rootPattern' of 'Control.Monad.Apiary.Action.ApiaryConfig'.-root :: (Functor m, Monad m, Monad n) => ApiaryT c n m b -> ApiaryT c n m b+root :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () root = focus' DocRoot Nothing (RootPath:) return  -- | match all subsequent path. since 0.15.0.-anyPath :: (Functor m, Monad m, Monad n) => ApiaryT c n m b -> ApiaryT c n m b+anyPath :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () anyPath = focus' id Nothing (AnyPath:) return  --------------------------------------------------------------------------------@@ -136,16 +138,16 @@ -- examples: -- -- @--- query "key" (Proxy :: Proxy ('First' Int)) -- get first \'key\' query parameter as Int.--- query "key" (Proxy :: Proxy ('Option' (Maybe Int)) -- get first \'key\' query parameter as Int. allow without param or value.--- query "key" (Proxy :: Proxy ('Many' String) -- get all \'key\' query parameter as String.+-- query "key" ('First'  :: First Int) -- get first \'key\' query parameter as Int.+-- query "key" ('Option' :: Option (Maybe Int)) -- get first \'key\' query parameter as Int. allow without param or value.+-- query "key" ('Many'   :: Many String) -- get all \'key\' query parameter as String. -- @-query :: forall a as w n m b proxy. -      (ReqParam a, Strategy.Strategy w, MonadIO n)+query :: forall exts prms actM a w m. +      (ReqParam a, Strategy.Strategy w, MonadIO actM)       => QueryKey-      -> proxy (w a)-      -> ApiaryT (Strategy.SNext w as a) n m b-      -> ApiaryT as n m b+      -> w a+      -> ApiaryT exts (Strategy.SNext w prms a) actM m ()+      -> ApiaryT exts prms actM m () query QueryKey{..} p =     focus doc $ \l -> do         r     <- getRequest@@ -153,17 +155,17 @@          maybe mzero return $             Strategy.readStrategy id ((queryKey ==) . fst) p -            (reqParams (Proxy :: Proxy a) r q f) l+            (reqParams p r q f) l   where-    doc = DocQuery queryKey (Strategy.strategyRep (Proxy :: Proxy w)) (reqParamRep (Proxy :: Proxy a)) queryDesc+    doc = DocQuery queryKey (Strategy.strategyRep p) (reqParamRep (Proxy :: Proxy a)) queryDesc  -- | get first matched paramerer. since 0.5.0.0. -- -- @--- "key" =: pInt == query "key" (pFirst pInt) == query "key" (Proxy :: Proxy (First Int))+-- "key" =: pInt == query "key" (pFirst pInt) == query "key" (First :: First Int) -- @-(=:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -     -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b+(=:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p+     -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m () k =: t = query k (Strategy.pFirst t)  -- | get one matched paramerer. since 0.5.0.0.@@ -171,100 +173,117 @@ -- when more one parameger given, not matched. -- -- @--- "key" =: pInt == query "key" (pOne pInt) == query "key" (Proxy :: Proxy (One Int))+-- "key" =: pInt == query "key" (pOne pInt) == query "key" (One :: One Int) -- @-(=!:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -      -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b+(=!:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p+      -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m () k =!: t = query k (Strategy.pOne t)  -- | get optional first paramerer. since 0.5.0.0. ----- when illegal type parameter given, fail mather(don't give Nothing).+-- when illegal type parameter given, fail match(don't give Nothing). -- -- @--- "key" =: pInt == query "key" (pOption pInt) == query "key" (Proxy :: Proxy (Option Int))+-- "key" =: pInt == query "key" (pOption pInt) == query "key" (Option :: Option Int) -- @-(=?:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -      -> ApiaryT (Snoc as (Maybe a)) n m b -> ApiaryT as n m b+(=?:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p+      -> ApiaryT exts (Maybe p ': prms) actM m () -> ApiaryT exts prms actM m () k =?: t = query k (Strategy.pOption t) +-- | get optional first paramerer with default. since 0.16.0.+--+-- when illegal type parameter given, fail match(don't give Nothing).+--+-- @+-- "key" =: (0 :: Int) == query "key" (pOptional (0 :: Int)) == query "key" (Optional 0 :: Optional Int)+-- @+(=?!:) :: (MonadIO actM, ReqParam p, Show p) => QueryKey -> p+       -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m ()+k =?!: v = query k (Strategy.pOptional v)+ -- | check parameger given and type. since 0.5.0.0. -- -- If you wan't to allow any type, give 'pVoid'. -- -- @--- "key" =: pInt == query "key" (pCheck pInt) == query "key" (Proxy :: Proxy (Check Int))+-- "key" =: pInt == query "key" (pCheck pInt) == query "key" (Check :: Check Int) -- @-(?:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -     -> ApiaryT as n m b -> ApiaryT as n m b+(?:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p+     -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () k ?: t = query k (Strategy.pCheck t)  -- | get many paramerer. since 0.5.0.0. -- -- @--- "key" =: pInt == query "key" (pMany pInt) == query "key" (Proxy :: Proxy (Many Int))+-- "key" =: pInt == query "key" (pMany pInt) == query "key" (Many :: Many Int) -- @-(=*:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -      -> ApiaryT (Snoc as [a]) n m b -> ApiaryT as n m b+(=*:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p+      -> ApiaryT exts ([p] ': prms) actM m () -> ApiaryT exts prms actM m () k =*: t = query k (Strategy.pMany t)  -- | get some paramerer. since 0.5.0.0. -- -- @--- "key" =: pInt == query "key" (pSome pInt) == query "key" (Proxy :: Proxy (Some Int))+-- "key" =: pInt == query "key" (pSome pInt) == query "key" (Some :: Some Int) -- @-(=+:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a -      -> ApiaryT (Snoc as [a]) n m b -> ApiaryT as n m b+(=+:) :: (MonadIO actM, ReqParam p) => QueryKey -> proxy p+      -> ApiaryT exts ([p] ': prms) actM m () -> ApiaryT exts prms actM m () k =+: t = query k (Strategy.pSome t)  -- | query exists checker. -- -- @--- hasQuery q = 'query' q (Proxy :: Proxy ('Check' ()))+-- hasQuery q = 'query' q (Check :: 'Check' ()) -- @ ---hasQuery :: (MonadIO n) => QueryKey -> ApiaryT c n m a -> ApiaryT c n m a-hasQuery q = query q (Proxy :: Proxy (Strategy.Check ()))+hasQuery :: MonadIO actM => QueryKey -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+hasQuery q = query q (Strategy.Check :: Strategy.Check ())  --------------------------------------------------------------------------------  -- | check whether to exists specified header or not. since 0.6.0.0.-hasHeader :: Monad n => HT.HeaderName -> ApiaryT as n m b -> ApiaryT as n m b+hasHeader :: Monad actM => HT.HeaderName -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () hasHeader n = header' Strategy.pCheck ((n ==) . fst) . Just $     toHtml (show n) <> " header requred"  -- | check whether to exists specified valued header or not. since 0.6.0.0.-eqHeader :: Monad n+eqHeader :: Monad actM          => HT.HeaderName           -> S.ByteString  -- ^ header value-         -> ApiaryT as n m b-         -> ApiaryT as n m b+         -> ApiaryT exts prms actM m ()+         -> ApiaryT exts prms actM m () eqHeader k v = header' Strategy.pCheck (\(k',v') -> k == k' && v == v') . Just $     mconcat [toHtml $ show k, " header == ", toHtml $ show v]  -- | filter by header and get first. since 0.6.0.0.-header :: Monad n => HT.HeaderName-       -> ApiaryT (Snoc as S.ByteString) n m b -> ApiaryT as n m b+header :: Monad actM => HT.HeaderName+       -> ApiaryT exts (S.ByteString ': prms) actM m () -> ApiaryT exts prms actM m () header n = header' Strategy.pFirst ((n ==) . fst) . Just $     toHtml (show n) <> " header requred"  -- | filter by headers up to 100 entries. since 0.6.0.0.-headers :: Monad n => HT.HeaderName-        -> ApiaryT (Snoc as [S.ByteString]) n m b -> ApiaryT as n m b-headers n = header' limit100 ((n ==) . fst) . Just $+headers :: Monad actM => HT.HeaderName+        -> ApiaryT exts ([S.ByteString] ': prms) actM m () -> ApiaryT exts prms actM m ()+headers n = header' (Strategy.pLimitSome 100) ((n ==) . fst) . Just $     toHtml (show n) <> " header requred"-  where-    limit100 :: Proxy x -> Proxy (Strategy.LimitSome $(int 100) x)-    limit100 _ = Proxy  -- | low level header filter. since 0.6.0.0.-header' :: (Strategy.Strategy w, Monad n)-        => (forall x. Proxy x -> Proxy (w x))+header' :: (Strategy.Strategy w, Monad actM)+        => (forall x. Proxy x -> w x)         -> (HT.Header -> Bool)         -> Maybe Html-        -> ApiaryT (Strategy.SNext w as S.ByteString) n m b-        -> ApiaryT as n m b+        -> ApiaryT exts (Strategy.SNext w prms S.ByteString) actM m ()+        -> ApiaryT exts prms actM m () header' pf kf d = function pc $ \l r ->     Strategy.readStrategy Just kf (pf pByteString) (requestHeaders r) l   where     pc = maybe id DocPrecondition d++-- | require Accept header and set response Content-Type. since 0.16.0.+accept :: Monad actM => ContentType -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+accept ect = focus (DocPrecondition $ "Accept: " <> toHtml (T.decodeUtf8 ect)) $ \c ->+    (lookup "Accept" . requestHeaders <$> getRequest) >>= \case+        Nothing -> mzero+        Just ct -> if ect == fst (parseContentType ct)+                   then contentType ect >> return c+                   else mzero

@@ -1,3 +1,6 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+ module Control.Monad.Apiary.Filter.Internal     ( function, function', function_, focus     ) where@@ -12,19 +15,19 @@ import Data.Apiary.Document  -- | low level filter function.-function :: Monad n => (Doc -> Doc)-         -> (SList c -> Request -> Maybe (SList c'))-         -> ApiaryT c' n m b -> ApiaryT c n m b+function :: Monad actM => (Doc -> Doc)+         -> (SList prms -> Request -> Maybe (SList prms'))+         -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m () function d f = focus d $ \c -> getRequest >>= \r -> case f c r of     Nothing -> mzero     Just c' -> return c'  -- | filter and append argument.-function' :: Monad n => (Doc -> Doc) -> (Request -> Maybe a)-          -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b-function' d f = function d $ \c r -> sSnoc c `fmap` f r+function' :: Monad actM => (Doc -> Doc) -> (Request -> Maybe prm)+          -> ApiaryT exts (prm ': prms) actM m () -> ApiaryT exts prms actM m ()+function' d f = function d $ \c r -> (::: c) `fmap` f r  -- | filter only(not modify arguments).-function_ :: Monad n => (Doc -> Doc) -> (Request -> Bool) -          -> ApiaryT c n m b -> ApiaryT c n m b+function_ :: Monad actM => (Doc -> Doc) -> (Request -> Bool) +          -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () function_ d f = function d $ \c r -> if f r then Just c else Nothing

@@ -26,17 +26,18 @@ import Text.Blaze.Html  -- | check first path and drill down. since 0.11.0.-path :: Monad n => T.Text -> ApiaryT c n m a -> ApiaryT c n m a+path :: Monad actM => T.Text -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () path p = focus' (DocPath p) Nothing (Exact p:) return  -- | check consumed paths. since 0.11.1.-endPath :: (Functor n, Monad n) => ApiaryT c n m a -> ApiaryT c n m a+endPath :: (Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () endPath = focus' id Nothing (EndPath:) return  -- | get first path and drill down. since 0.11.0.-fetch :: (Path a, Functor n, Monad n) => proxy a -> Maybe Html -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b+fetch :: (Path p, Monad actM) => proxy p -> Maybe Html+      -> ApiaryT exts (p ': prms) actM m () -> ApiaryT exts prms actM m () fetch p h = focus' (DocFetch (pathRep p) h) Nothing (FetchPath:) $ \l -> liftM actionFetches getState >>= \case     []   -> mzero     f:fs -> case readPathAs p f of-        Just r  -> sSnoc l r <$ modifyState (\s -> s {actionFetches = fs})+        Just r  -> (r ::: l) <$ modifyState (\s -> s {actionFetches = fs})         Nothing -> mzero

@@ -10,6 +10,7 @@ import qualified Control.Monad.Apiary.Filter.Internal.Capture as Capture  import qualified Data.Text as T+import Data.String import Data.Proxy  preCap :: String -> [String]@@ -50,7 +51,7 @@             N n  -> [|Just $(varE n)|]     [|Capture.fetch (Proxy :: Proxy $(conT ty)) $d . $(mkCap as)|] mkCap (eq:as) = do-    [|(Capture.path $(stringE eq)) . $(mkCap as) |]+    [|(Capture.path (fromString $(stringE eq))) . $(mkCap as) |]  -- | capture QuasiQuoter. since 0.1.0.0. --

@@ -5,7 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-}@@ -13,7 +13,6 @@ module Control.Monad.Apiary.Filter.Internal.Strategy where  import Data.Maybe-import Data.Reflection import qualified Data.Text as T  import Data.Apiary.Proxy@@ -24,93 +23,100 @@     type SNext w (as :: [*]) a  :: [*]     readStrategy :: (v -> Maybe a)                  -> ((k,v) -> Bool)-                 -> proxy (w a)+                 -> w a                  -> [(k, v)]                  -> SList as                   -> Maybe (SList (SNext w as a))-    strategyRep :: proxy w -> StrategyRep+    strategyRep :: forall a. w a -> StrategyRep -getQuery :: (v -> Maybe a) -> proxy (w a) -> ((k,v) -> Bool) -> [(k, v)] -> [Maybe a]+getQuery :: (v -> Maybe a) -> w a -> ((k,v) -> Bool) -> [(k, v)] -> [Maybe a] getQuery readf _ kf = map readf . map snd . filter kf  -- | get first matched key( [0,) params to Type.). since 0.5.0.0.-data Option a deriving Typeable+data Option a = Option deriving Typeable instance Strategy Option where-    type SNext Option as a = Snoc as (Maybe a)+    type SNext Option as a = Maybe a ': as     readStrategy rf k p q l =         let rs = getQuery rf p k q         in if any isNothing rs            then Nothing-           else Just . sSnoc l $ case catMaybes rs of-               []  -> Nothing+           else Just . (::: l) $ case catMaybes rs of                a:_ -> Just a+               []  -> Nothing     strategyRep _ = StrategyRep "optional" +data Optional a = Optional T.Text a deriving Typeable+instance Strategy Optional where+    type SNext Optional as a = a ': as+    readStrategy rf k p@(Optional _ def) q l =+        let rs = getQuery rf p k q+        in if any isNothing rs+           then Nothing+           else Just . (::: l) $ case catMaybes rs of+               a:_ -> a+               []  -> def+    strategyRep (Optional tr _) = StrategyRep $+        "default:" `T.append` tr+ -- | get first matched key ( [1,) params to Maybe Type.) since 0.5.0.0.-data First a deriving Typeable+data First a = First deriving Typeable instance Strategy First where-    type SNext First as a = Snoc as a+    type SNext First as a = a ': as     readStrategy rf k p q l =         case getQuery rf p k q of-            Just a:_ -> Just $ sSnoc l a+            Just a:_ -> Just $ a ::: l             _        -> Nothing     strategyRep _ = StrategyRep "first"  -- | get key ( [1,1] param to Type.) since 0.5.0.0.-data One a deriving Typeable+data One a = One deriving Typeable instance Strategy One where-    type SNext One as a = Snoc as a+    type SNext One as a = a ': as     readStrategy rf k p q l =         case getQuery rf p k q of-            [Just a] -> Just $ sSnoc l a+            [Just a] -> Just $ a ::: l             _        -> Nothing     strategyRep _ = StrategyRep "one"  -- | get parameters ( [0,) params to [Type] ) since 0.5.0.0.-data Many a deriving Typeable+data Many a = Many deriving Typeable instance Strategy Many where-    type SNext Many as a = Snoc as [a]+    type SNext Many as a = [a] ': as     readStrategy rf k p q l =         let rs = getQuery rf p k q         in if any isNothing rs            then Nothing-           else Just $ sSnoc l (catMaybes rs)+           else Just $ (catMaybes rs) ::: l     strategyRep _ = StrategyRep "many"  -- | get parameters ( [1,) params to [Type] ) since 0.5.0.0.-data Some a deriving Typeable+data Some a = Some deriving Typeable instance Strategy Some where-    type SNext Some as a = Snoc as [a]+    type SNext Some as a = [a] ': as     readStrategy rf k p q l =         let rs = getQuery rf p k q         in if any isNothing rs            then Nothing            else case catMaybes rs of                [] -> Nothing-               as -> Just $ sSnoc l as+               as -> Just $ as ::: l     strategyRep _ = StrategyRep "some"  -- | get parameters with upper limit ( [1,n] to [Type]) since 0.6.0.0.-data LimitSome u a deriving Typeable-instance (Reifies u Int) => Strategy (LimitSome u) where-    type SNext (LimitSome u) as a = Snoc as [a]-    readStrategy rf k p q l =-        let rs = take (reflectLimit p) $ getQuery rf p k q+data LimitSome a = LimitSome {-# UNPACK #-} !Int deriving Typeable+instance Strategy LimitSome where+    type SNext LimitSome as a = [a] ': as+    readStrategy rf k p@(LimitSome lim) q l =+        let rs = take lim $ getQuery rf p k q         in if any isNothing rs            then Nothing            else case catMaybes rs of                [] -> Nothing-               as -> Just $ sSnoc l as-    strategyRep _ = StrategyRep . T.pack $ "less then " ++ show (reflect (Proxy :: Proxy u))--reflectLimit :: Reifies n Int => proxy (LimitSome n a) -> Int-reflectLimit p = reflect $ asTyInt p-  where-    asTyInt :: proxy (LimitSome u a) -> Proxy u-    asTyInt _ = Proxy+               as -> Just $ as ::: l+    strategyRep (LimitSome lim) = StrategyRep . T.pack $ "less then " ++ show lim  -- | type check ( [0,) params to No argument ) since 0.5.0.0.-data Check a deriving Typeable+data Check a = Check deriving Typeable instance Strategy Check where     type SNext Check as a = as     readStrategy rf k p q l =@@ -123,25 +129,33 @@     strategyRep _ = StrategyRep "check"  -- | construct Option proxy. since 0.5.1.0.-pOption :: proxy a -> Proxy (Option a)-pOption _ = Proxy+pOption :: proxy a -> Option a+pOption _ = Option +-- | construct Optional proxy. since 0.16.0.+pOptional :: Show a => a -> Optional a+pOptional def = Optional (T.pack $ show def) def+ -- | construct First proxy. since 0.5.1.0.-pFirst :: proxy a -> Proxy (First a)-pFirst _ = Proxy+pFirst :: proxy a -> First a+pFirst _ = First  -- | construct One proxy. since 0.5.1.0.-pOne :: proxy a -> Proxy (One a)-pOne _ = Proxy+pOne :: proxy a -> One a+pOne _ = One  -- | construct Many proxy. since 0.5.1.0.-pMany :: proxy a -> Proxy (Many a)-pMany _ = Proxy+pMany :: proxy a -> Many a+pMany _ = Many  -- | construct Some proxy. since 0.5.1.0.-pSome :: proxy a -> Proxy (Some a)-pSome _ = Proxy+pSome :: proxy a -> Some a+pSome _ = Some +-- | construct LimitSome proxy. since 0.16.0.+pLimitSome :: Int -> proxy a -> LimitSome a+pLimitSome lim _ = LimitSome lim+ -- | construct Check proxy. since 0.5.1.0.-pCheck :: proxy a -> Proxy (Check a)-pCheck _ = Proxy+pCheck :: proxy a -> Check a+pCheck _ = Check

@@ -12,6 +12,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}  module Control.Monad.Apiary.Internal where @@ -20,40 +21,42 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans-import Control.Monad.Identity import Control.Monad.Trans.Control import Control.Monad.Base import Control.Monad.Apiary.Action.Internal  import Data.List import Data.Apiary.SList+import Data.Apiary.Extension+import Data.Apiary.Extension.Internal import Data.Apiary.Document-import Data.Monoid+import Data.Monoid hiding (All) import Text.Blaze.Html import qualified Data.Text as T import qualified Data.ByteString as S import Data.Apiary.Method import qualified Data.HashMap.Strict as H -data Router n = Router-    { children   :: H.HashMap T.Text (Router n)-    , capturing  :: Maybe (Router n)-    , anyMatch   :: Maybe (PathMethod n)-    , pathMethod :: PathMethod n+data Router exts actM = Router+    { children   :: H.HashMap T.Text (Router exts actM)+    , capturing  :: Maybe (Router exts actM)+    , anyMatch   :: Maybe (PathMethod exts actM)+    , pathMethod :: PathMethod exts actM     } -data PathMethod n = PathMethod-    { methodMap :: H.HashMap S.ByteString (ActionT n ())-    , anyMethod :: Maybe (ActionT n ())+data PathMethod exts actM = PathMethod+    { methodMap :: H.HashMap S.ByteString (ActionT exts actM ())+    , anyMethod :: Maybe (ActionT exts actM ())     } -emptyRouter :: Router n+emptyRouter :: Router exts actM emptyRouter = Router H.empty Nothing Nothing emptyPathMethod -emptyPathMethod :: PathMethod n+emptyPathMethod :: PathMethod exts actM emptyPathMethod = PathMethod H.empty Nothing -insertRouter :: Monad n => [T.Text] -> Maybe S.ByteString -> [PathElem] -> ActionT n () -> Router n -> Router n+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) =@@ -82,41 +85,41 @@               | EndPath               | AnyPath -data ApiaryEnv n c = ApiaryEnv-    { envFilter :: ActionT n (SList c)+data ApiaryEnv exts prms actM = ApiaryEnv+    { envFilter :: ActionT exts actM (SList prms)     , envMethod :: Maybe Method     , envPath   :: [PathElem] -> [PathElem]     , envConfig :: ApiaryConfig     , envDoc    :: Doc -> Doc+    , envExts   :: Extensions exts     } -initialEnv :: Monad n => ApiaryConfig -> ApiaryEnv n '[]-initialEnv conf = ApiaryEnv (return SNil) Nothing id conf id+initialEnv :: Monad actM => Extensions exts -> ApiaryConfig -> ApiaryEnv exts '[] actM+initialEnv exts conf = ApiaryEnv (return SNil) Nothing id conf id exts -data ApiaryWriter n = ApiaryWriter-    { writerRouter :: Router n -> Router n+data ApiaryWriter exts actM = ApiaryWriter+    { writerRouter :: Router exts actM -> Router exts actM     , writerDoc    :: [Doc] -> [Doc]+    , writerMw     :: Middleware     } -instance Monoid (ApiaryWriter n) where-    mempty = ApiaryWriter id id-    ApiaryWriter ra da `mappend` ApiaryWriter rb db = ApiaryWriter (ra . rb) (da . db)+instance Monoid (ApiaryWriter exts actM) where+    mempty = ApiaryWriter id id id+    ApiaryWriter ra da am `mappend` ApiaryWriter rb db bm+        = ApiaryWriter (ra . rb) (da . db) (am . bm)  -- | most generic Apiary monad. since 0.8.0.0.-newtype ApiaryT c n m a = ApiaryT { unApiaryT :: forall b.-    ApiaryEnv n c-    -> (a -> ApiaryWriter n -> m b)+newtype ApiaryT exts prms actM m a = ApiaryT { unApiaryT :: forall b.+    ApiaryEnv exts prms actM+    -> (a -> ApiaryWriter exts actM -> m b)     -> m b      } apiaryT :: Monad m-        => (ApiaryEnv n c -> m (a, ApiaryWriter n))-        -> ApiaryT c n m a+        => (ApiaryEnv exts prms actM -> m (a, ApiaryWriter exts actM))+        -> ApiaryT exts prms actM m a apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a,w) -> cont a w --- | no transformer. (ActionT IO, ApiaryT Identity)-type Apiary c = ApiaryT c IO Identity--routerToAction :: Monad n => Router n -> ActionT n ()+routerToAction :: Monad actM => Router exts actM -> ActionT exts actM () routerToAction router = getRequest >>= go   where     go req = loop id router (pathInfo req)@@ -140,23 +143,33 @@                 Nothing -> nxt                 Just cd -> loop fch cd ps `mplus` nxt -runApiaryT :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig-           -> ApiaryT '[] n m a -> m Application-runApiaryT run conf m = unApiaryT m (initialEnv conf) (\_ w -> return w) >>= \wtr -> do+runApiaryTWith :: (Monad actM, Monad m) => Initializer '[] m exts+               -> ApiaryConfig -> (forall b. actM b -> IO b) -> ApiaryT exts '[] actM m () -> m Application+runApiaryTWith (Initializer ir) conf run m = do+    exts <- ir NoExtension+    wtr  <- unApiaryT m (initialEnv exts conf) (\_ w -> return w)     let doc = docsToDocuments $ writerDoc wtr []         rtr = writerRouter wtr emptyRouter-    return $! execActionT conf doc (hoistActionT run $ routerToAction rtr)+        mw  = writerMw wtr+    return $! mw $ execActionT conf exts doc (hoistActionT run $ routerToAction rtr) -runApiary :: ApiaryConfig -> Apiary '[] a -> Application-runApiary conf m = runIdentity $ runApiaryT id conf m+runApiaryWith :: Monad m => Initializer '[] m exts+              -> ApiaryConfig -> ApiaryT exts '[] IO m () -> m Application+runApiaryWith ef conf m = runApiaryTWith ef conf id m +runApiary :: Monad m => ApiaryConfig -> ApiaryT '[] '[] IO m () -> m Application+runApiary = runApiaryWith noExtension++server :: Monad m => (Application -> m a) -> m Application -> m a+server = (=<<)+ -------------------------------------------------------------------------------- -instance Functor (ApiaryT c n m) where+instance Functor (ApiaryT exts prms actM m) where     fmap f m = ApiaryT $ \env cont ->         unApiaryT m env $ \a hdr -> hdr `seq` cont (f a) hdr -instance Monad n => Applicative (ApiaryT c n m) where+instance Monad actM => Applicative (ApiaryT exts prms actM m) where     pure x = ApiaryT $ \_ cont -> cont x mempty     mf <*> ma = ApiaryT $ \env cont ->         unApiaryT mf env $ \f hdr  ->@@ -164,7 +177,7 @@         let hdr'' = hdr <> hdr'         in hdr'' `seq` cont (f a) hdr'' -instance Monad n => Monad (ApiaryT c n m) where+instance Monad actM => Monad (ApiaryT exts prms actM m) where     return x = ApiaryT $ \_ cont -> cont x mempty     m >>= k = ApiaryT $ \env cont ->         unApiaryT    m  env $ \a hdr  ->@@ -172,51 +185,54 @@         let hdr'' = hdr <> hdr'         in hdr'' `seq` cont b hdr'' -instance Monad n => MonadTrans (ApiaryT c n) where+instance Monad actM => MonadTrans (ApiaryT exts prms actM) where     lift m = ApiaryT $ \_ c -> m >>= \a -> c a mempty -instance (Monad n, MonadIO m) => MonadIO (ApiaryT c n m) where+instance (Monad actM, MonadIO m) => MonadIO (ApiaryT exts prms actM m) where     liftIO m = ApiaryT $ \_ c -> liftIO m >>= \a -> c a mempty -instance (Monad n, MonadBase b m) => MonadBase b (ApiaryT c n m) where+instance (Monad actM, MonadBase b m) => MonadBase b (ApiaryT exts prms actM m) where     liftBase m = ApiaryT $ \_ c -> liftBase m >>= \a -> c a mempty -instance Monad n => MonadTransControl (ApiaryT c n) where-    newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter n) }+instance Monad actM => MonadTransControl (ApiaryT exts prms actM) where+    newtype StT (ApiaryT exts prms actM) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter exts actM) }     liftWith f = apiaryT $ \env ->         liftM (\a -> (a, mempty))          (f $ \t -> liftM StTApiary' $ unApiaryT t env (\a w -> return (a,w)))     restoreT m = apiaryT $ \_ -> liftM unStTApiary' m -instance (Monad n, MonadBaseControl b m) => MonadBaseControl b (ApiaryT c n m) where-    newtype StM (ApiaryT c n m) a = StMApiary' { unStMApiary' :: ComposeSt (ApiaryT c n) m a }+instance (Monad actM, MonadBaseControl b m) => MonadBaseControl b (ApiaryT exts prms actM m) where+    newtype StM (ApiaryT exts prms actM m) a = StMApiary' { unStMApiary' :: ComposeSt (ApiaryT exts prms actM) m a }     liftBaseWith = defaultLiftBaseWith StMApiary'     restoreM     = defaultRestoreM   unStMApiary'  -------------------------------------------------------------------------------- -getApiaryEnv :: Monad n => ApiaryT c n m (ApiaryEnv n c)+getApiaryEnv :: Monad actM => ApiaryT exts prms actM m (ApiaryEnv exts prms actM) getApiaryEnv = ApiaryT $ \env cont -> cont env mempty -apiaryConfig :: Monad n => ApiaryT c n m ApiaryConfig+apiaryConfig :: Monad actM => ApiaryT exts prms actM m ApiaryConfig apiaryConfig = liftM envConfig getApiaryEnv -addRoute :: Monad n => ApiaryWriter n -> ApiaryT c n m ()+apiaryExt :: (Has e exts, Monad actM) => proxy e -> ApiaryT exts prms actM m e+apiaryExt p = liftM (getExtension p . envExts) getApiaryEnv++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.-focus :: Monad n+focus :: Monad actM       => (Doc -> Doc)-      -> (SList c -> ActionT n (SList c'))-      -> ApiaryT c' n m a -> ApiaryT c n m a+      -> (SList prms -> ActionT exts actM (SList prms'))+      -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m () focus d g m = focus' d Nothing id g m -focus' :: Monad n+focus' :: Monad actM        => (Doc -> Doc)        -> Maybe Method        -> ([PathElem] -> [PathElem])-       -> (SList c -> ActionT n (SList c'))-       -> ApiaryT c' n m a -> ApiaryT c n m a+       -> (SList prms -> ActionT exts actM (SList prms'))+       -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m () focus' d meth pth g m = ApiaryT $ \env cont -> unApiaryT m env      { envFilter = envFilter env >>= g      , envMethod = maybe (envMethod env) Just meth@@ -225,11 +241,11 @@     } cont  -- | splice ActionT ApiaryT.-action :: Monad n => Fn c (ActionT n ()) -> ApiaryT c n m ()+action :: Monad actM => Fn prms (ActionT exts actM ()) -> ApiaryT exts prms actM m () action = action' . apply  -- | like action. but not apply arguments. since 0.8.0.0.-action' :: Monad n => (SList c -> ActionT n ()) -> ApiaryT c n m ()+action' :: Monad actM => (SList prms -> ActionT exts actM ()) -> ApiaryT exts prms actM m () action' a = do     env <- getApiaryEnv     addRoute $ ApiaryWriter@@ -237,39 +253,43 @@             (rootPattern $ envConfig env)             (renderMethod <$> envMethod env)             (envPath env [])-            (envFilter env >>= \c -> a c))+            (envFilter env >>= \prms -> a prms))         (envDoc env Action:)+        id++middleware :: Monad actM => Middleware -> ApiaryT exts prms actM m ()+middleware mw = addRoute (ApiaryWriter id id mw)+ -------------------------------------------------------------------------------- -insDoc :: (Doc -> Doc) -> ApiaryT c n m a -> ApiaryT c n m a+insDoc :: (Doc -> Doc) -> ApiaryT exts prms actM m () -> ApiaryT exts prms 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 c n m a -> ApiaryT c n m a+group :: T.Text -> ApiaryT exts prms actM m () -> ApiaryT exts prms 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 c n m a -> ApiaryT c n m a+document :: T.Text -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () document = insDoc . Document  -- | add user defined precondition. since 0.13.0.-precondition :: Html -> ApiaryT c n m a -> ApiaryT c n m a+precondition :: Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () precondition = insDoc . DocPrecondition -noDoc :: ApiaryT c n m a -> ApiaryT c n m a+noDoc :: ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () noDoc = insDoc DocDropNext  --------------------------------------------------------------------------------  {-# DEPRECATED actionWithPreAction "use action'" #-} -- | execute action before main action. since 0.4.2.0-actionWithPreAction :: Monad n => (SList xs -> ActionT n a)-                    -> Fn xs (ActionT n ()) -> ApiaryT xs n m ()-actionWithPreAction pa a = do-    action' $ \c -> pa c >> apply a c+actionWithPreAction :: Monad actM => (SList xs -> ActionT exts actM a)+                    -> Fn xs (ActionT exts actM ()) -> ApiaryT exts xs actM m ()+actionWithPreAction pa a = action' $ \prms -> pa prms >> apply a prms

@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ConstraintKinds #-}++module Data.Apiary.Extension+    ( Has(getExtension)+    , Extensions+    , addExtension+    , Initializer, Initializer'+    , initializer, preAction, (+>)+    , noExtension+    ) where++import Data.Apiary.Extension.Internal++type Initializer' m a = forall i. Initializer i m (a ': i)++addExtension :: e -> Extensions es -> Extensions (e ': es)+addExtension = AddExtension++initializer :: Monad m => m e -> Initializer' m e+initializer m = Initializer $ \e -> do+    a <- m+    return (addExtension a e)++preAction :: Monad m => m a -> Initializer i m i+preAction f = Initializer $ \e -> f >> return e++(+>) :: Monad m => Initializer i m x -> Initializer x m o -> Initializer i m o+Initializer a +> Initializer b = Initializer $ \e -> a e >>= b++noExtension :: Monad m => Initializer '[] m '[]+noExtension = Initializer $ return

@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TypeOperators #-}++module Data.Apiary.Extension.Internal where++newtype Initializer i m o = Initializer +    {unInitializer :: Extensions i -> m (Extensions o)}++data Extensions (es :: [*]) where+    NoExtension  :: Extensions '[]+    AddExtension :: (e :: *) -> Extensions es -> Extensions (e ': es)++class Has a (as :: [*]) where+    getExtension :: proxy a -> Extensions as -> a++instance Has a (a ': as) where+    getExtension _ (AddExtension a _) = a++instance Has a as => Has a (a' ': as) where+    getExtension p (AddExtension _ as) = getExtension p as+

@@ -18,12 +18,15 @@  import Network.Wai +import Control.Monad+ import Data.Int import Data.Word import Data.Proxy import Data.Apiary.Proxy  import Data.String(IsString)+import Data.Time.Calendar import qualified Data.Text.Read as TR import Data.Text.Encoding.Error import qualified Data.Text as T@@ -63,12 +66,12 @@     | Check     deriving (Show, Eq) -class Typeable a => Path a where+class Path a where     readPath :: T.Text  -> Maybe a     pathRep  :: proxy a -> TypeRep-    pathRep = typeRep  instance Path Char where+    pathRep = typeRep     readPath s         | T.null s  = Nothing         | otherwise = Just $ T.head s@@ -89,23 +92,23 @@  -- | javascript boolean. -- when \"false\", \"0\", \"-0\", \"\", \"null\", \"undefined\", \"NaN\" then False, else True. since 0.6.0.0.-instance Path Bool    where readPath = Just . jsToBool+instance Path Bool    where readPath = Just . jsToBool; pathRep = typeRep -instance Path Int     where readPath = readTextInt-instance Path Int8    where readPath = readTextInt-instance Path Int16   where readPath = readTextInt-instance Path Int32   where readPath = readTextInt-instance Path Int64   where readPath = readTextInt-instance Path Integer where readPath = readTextInt+instance Path Int     where readPath = readTextInt; pathRep = typeRep+instance Path Int8    where readPath = readTextInt; pathRep = typeRep+instance Path Int16   where readPath = readTextInt; pathRep = typeRep+instance Path Int32   where readPath = readTextInt; pathRep = typeRep+instance Path Int64   where readPath = readTextInt; pathRep = typeRep+instance Path Integer where readPath = readTextInt; pathRep = typeRep -instance Path Word    where readPath = readTextWord-instance Path Word8   where readPath = readTextWord-instance Path Word16  where readPath = readTextWord-instance Path Word32  where readPath = readTextWord-instance Path Word64  where readPath = readTextWord+instance Path Word    where readPath = readTextWord; pathRep = typeRep+instance Path Word8   where readPath = readTextWord; pathRep = typeRep+instance Path Word16  where readPath = readTextWord; pathRep = typeRep+instance Path Word32  where readPath = readTextWord; pathRep = typeRep+instance Path Word64  where readPath = readTextWord; pathRep = typeRep -instance Path Double  where readPath = readTextDouble-instance Path Float   where readPath = fmap realToFrac . readTextDouble+instance Path Double  where readPath = readTextDouble; pathRep = typeRep+instance Path Float   where readPath = fmap realToFrac . readTextDouble; pathRep = typeRep  instance Path  T.Text      where readPath = Just;                 pathRep _ = typeRep (Proxy :: Proxy Text) instance Path TL.Text      where readPath = Just . TL.fromStrict; pathRep _ = typeRep (Proxy :: Proxy Text)@@ -113,14 +116,14 @@ instance Path L.ByteString where readPath = Just . TL.encodeUtf8 . TL.fromStrict; pathRep _ = typeRep (Proxy :: Proxy Text) instance Path String       where readPath = Just . T.unpack;      pathRep _ = typeRep (Proxy :: Proxy Text) + -------------------------------------------------------------------------------- -class Typeable a => Query a where+class Query a where     readQuery :: Maybe S.ByteString -> Maybe a     queryRep  :: proxy a            -> QueryRep     queryRep = Strict . qTypeRep     qTypeRep  :: proxy a            -> TypeRep-    qTypeRep = typeRep  readBS :: (S.ByteString -> Maybe (a, S.ByteString))        -> S.ByteString -> Maybe a@@ -139,25 +142,25 @@  -- | 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+instance Query Bool    where readQuery = fmap jsToBool; qTypeRep = typeRep -instance Query Int     where readQuery = maybe Nothing readBSInt-instance Query Int8    where readQuery = maybe Nothing readBSInt-instance Query Int16   where readQuery = maybe Nothing readBSInt-instance Query Int32   where readQuery = maybe Nothing readBSInt-instance Query Int64   where readQuery = maybe Nothing readBSInt-instance Query Integer where readQuery = maybe Nothing readBSInt+instance Query Int     where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep+instance Query Int8    where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep+instance Query Int16   where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep+instance Query Int32   where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep+instance Query Int64   where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep+instance Query Integer where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep -instance Query Word    where readQuery = maybe Nothing readBSWord-instance Query Word8   where readQuery = maybe Nothing readBSWord-instance Query Word16  where readQuery = maybe Nothing readBSWord-instance Query Word32  where readQuery = maybe Nothing readBSWord-instance Query Word64  where readQuery = maybe Nothing readBSWord+instance Query Word    where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep+instance Query Word8   where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep+instance Query Word16  where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep+instance Query Word32  where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep+instance Query Word64  where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep -instance Query Double  where readQuery = maybe Nothing readBSDouble-instance Query Float   where readQuery = maybe Nothing (fmap realToFrac . readBSDouble)+instance Query Double  where readQuery = maybe Nothing readBSDouble; qTypeRep = typeRep+instance Query Float   where readQuery = maybe Nothing (fmap realToFrac . readBSDouble); qTypeRep = typeRep -instance Query T.Text  where+instance Query T.Text where     readQuery  = fmap $ T.decodeUtf8With lenientDecode     qTypeRep _ = typeRep (Proxy :: Proxy Text) @@ -173,15 +176,57 @@     readQuery  = fmap L.fromStrict     qTypeRep _ = typeRep (Proxy :: Proxy Text) -instance Query String       where+instance Query String where     readQuery  = fmap S.unpack     qTypeRep _ = typeRep (Proxy :: Proxy Text) +-- | fuzzy date parse. three decimal split by 1 char.+-- if year < 100 then + 2000. since 0.16.0.+--+-- example:+--+-- * 2014-02-05+-- * 14-2-5+-- * 14.2.05+instance Query Day where+    readQuery = (>>= \s0 -> do+        (y, s1) <- SL.readDecimal s0+        when (S.null s1) Nothing+        (m, s2) <- SL.readDecimal (S.tail s1)+        when (S.null s2) Nothing+        (d, s3) <- SL.readDecimal (S.tail s2)+        unless (S.null s3) Nothing+        let y' = if y < 100 then 2000 + y else y+        return $ fromGregorian y' m d)+    qTypeRep _ = typeRep (Proxy :: Proxy Day)++-- | fuzzy date parse. three decimal split by 1 char.+-- if year < 100 then + 2000. since 0.16.0.+--+-- example:+--+-- * 2014-02-05+-- * 14-2-5+-- * 14.2.05+instance Path Day where+    readPath s0 = either (const Nothing) Just $ do+        (y, s1) <- TR.decimal s0+        when (T.null s1) (Left "")+        (m, s2) <- TR.decimal (T.tail s1)+        when (T.null s2) (Left "")+        (d, s3) <- TR.decimal (T.tail s2)+        unless (T.null s3) (Left "")+        let y' = if y < 100 then 2000 + y else y+        return $ fromGregorian y' m d+    pathRep _ = typeRep (Proxy :: Proxy Day)+ -- | allow no parameter. but check parameter type. instance Query a => Query (Maybe a) where     readQuery (Just a) = Just `fmap` readQuery (Just a)     readQuery Nothing  = Just Nothing     queryRep _         = Nullable $ qTypeRep (Proxy :: Proxy a)+    qTypeRep _         = maybeCon `mkTyConApp` [qTypeRep (Proxy :: Proxy a)]+      where maybeCon = typeRepTyCon $ typeOf (Nothing :: Maybe ())  -- | always success. for check existence. instance Query () where

@@ -6,6 +6,9 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}  module Data.Apiary.SList where @@ -17,28 +20,24 @@  infixr ::: -deriving instance All Show as => Show (SList as)--type family Fn (as :: [*]) r-type instance Fn '[] r = r-type instance Fn (x ': xs) r = x -> Fn xs r--type family Snoc (as :: [*]) a :: [*]-type instance Snoc '[] a = a ': '[]-type instance Snoc (x ': xs) a = x ': Snoc xs a- type family All (c :: * -> Constraint) (as :: [*]) :: Constraint type instance All c '[] = () type instance All c (a ': as) = (c a, All c as) -apply :: Fn xs r -> SList xs -> r-apply v SNil = v-apply f (a ::: as) = apply (f a) as+deriving instance All Show as => Show (SList as) -sSnoc :: SList as -> a -> SList (Snoc as a)-sSnoc SNil       a = a ::: SNil-sSnoc (x ::: xs) a = x ::: sSnoc xs a+type family Apply (as :: [*]) r+type instance Apply '[] r = r+type instance Apply (x ': xs) r = x -> Apply xs r +type Fn c a = Apply (Reverse c) a+apply :: Fn c r -> SList c -> r+apply f l = apply' f $ sReverse l++apply' :: Apply xs r -> SList xs -> r+apply' v SNil = v+apply' f (a ::: as) = apply' (f a) as+ type family Rev (l :: [*]) (a :: [*]) :: [*] type instance Rev '[] a = a type instance Rev (x ': xs) a = Rev xs (x ': a)@@ -51,4 +50,3 @@     rev :: SList as -> SList bs -> SList (Rev as bs)     rev SNil a = a     rev (x:::xs) a = rev xs (x:::a)-

@@ -3,18 +3,26 @@     , module Control.Monad.Apiary.Action     , module Control.Monad.Apiary.Filter     , module Data.Apiary.Param+    -- | Strategy Proxies+    , module Control.Monad.Apiary.Filter.Internal.Strategy+    -- | Method(..)+    , module Data.Apiary.Method+    -- | (+>)+    , module Data.Apiary.Extension     , act+     -- * reexports-    , module Data.Default.Class     , module Network.HTTP.Types.Status+    -- | def+    , module Data.Default.Class     -- | MonadIO-    , module Control.Monad.Trans-    -- | MonadPlus(..), msum, mfilter, guard+    , module Control.Monad.IO.Class+    -- | MonadPlus(..), msum, mfilter, guard, (>=>)     , module Control.Monad-    -- | Strategy Proxies-    , module Control.Monad.Apiary.Filter.Internal.Strategy     -- | FilePart(..)     , module Network.Wai+    -- | Html+    , module Text.Blaze.Html     ) where   import Web.Apiary.TH@@ -25,8 +33,11 @@ import Control.Monad.Apiary.Action import Control.Monad.Apiary.Filter import Control.Monad.Apiary.Filter.Internal.Strategy (pFirst, pOne, pOption, pCheck, pMany, pSome)-import Control.Monad.Trans(MonadIO(..))-import Control.Monad (MonadPlus(..), msum, mfilter, guard)+import Control.Monad.IO.Class(MonadIO(..))+import Control.Monad (MonadPlus(..), msum, mfilter, guard, (>=>)) -import Data.Default.Class+import Data.Default.Class(def) import Data.Apiary.Param+import Data.Apiary.Extension((+>))+import Data.Apiary.Method(Method(..))+import Text.Blaze.Html(Html)

@@ -0,0 +1,324 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++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"++--------------------------------------------------------------------------------++helloWorldApp :: Application+helloWorldApp = runIdentity . runApiary def $ 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 = runIdentity . runApiary def $ 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 = runIdentity . runApiary def $ 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 = runIdentity . runApiary def .  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"+    ]++--------------------------------------------------------------------------------+anyFilterApp :: Application+anyFilterApp = runIdentity . runApiary def $ [capture|/test|] . anyPath . action $ do+    contentType "text/plain"+    bytes "hello"++anyFilterTest :: Test+anyFilterTest = testGroup "anyPath" $ map ($ anyFilterApp)+    [ testReq "GET /"          . assert404+    , testReq "GET /test"      . assertPlain200 "hello"+    , testReq "POST /test/foo" . assertPlain200 "hello"+    ]++--------------------------------------------------------------------------------++captureApp :: Application+captureApp = runIdentity . runApiary def $ do+    [capture|/foo|]  . action $ contentType "text/plain" >> bytes "foo"+    [capture|/:Int|] . method GET . action $ \i -> contentType "text/plain" >> bytes "Int " >> showing i+    [capture|/:Double|] . action $ \i -> contentType "text/plain" >> bytes "Double " >> showing i+    [capture|/bar/:L.ByteString/:Int|] . action $ \s i -> contentType "text/plain" >> lazyBytes s >> char ' ' >> showing i+    [capture|/:L.ByteString|] . action $ \s -> contentType "text/plain" >> bytes "fall " >> lazyBytes s++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 = runIdentity . runApiary def $ do+    _ <- (f "foo" pInt)        . action $ \i -> contentType "text/plain" >> bytes "foo Int " >> showing i+    _ <- (g "foo" pString)     . action $ \i -> contentType "text/plain" >> bytes "foo String " >> showing i+    (h "foo" (pMaybe pString)) . action $ \i -> contentType "text/plain" >> bytes "foo Maybe String " >> showing i++queryOptionalApp :: Application+queryOptionalApp = runIdentity . runApiary def $ do+    ("foo" =?!: (5 :: Int))                   . action $ \i -> contentType "text/plain" >> bytes "foo Int " >> showing i+    ("foo" =?!: ("bar" :: String))            . action $ \i -> contentType "text/plain" >> bytes "foo String " >> showing i+    ("foo" =?!: (Just "baz" :: Maybe String)) . action $ \i -> contentType "text/plain" >> bytes "foo Maybe String " >> showing i++queryCheckApp :: Application+queryCheckApp = runIdentity . runApiary def $ do+    ("foo" ?: pInt)           . action $ contentType "text/plain" >> bytes "foo Int"+    ("foo" ?: pString)        . action $ contentType "text/plain" >> bytes "foo String"+    ("foo" ?: pMaybe pString) . action $ contentType "text/plain" >> bytes "foo Maybe String"++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 String 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 String \"12\""+    ]++queryCheckTest :: Test+queryCheckTest = testGroup "Check" $ map ($ queryCheckApp)+    [ testReq "GET /" . assert404+    , testReq "GET /?foo" . assertPlain200 "foo Maybe String"+    , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String"+    , testReq "GET /?foo=12" . assertPlain200 "foo Int"+    , testReq "GET /?foo=a" . assertPlain200 "foo String"+    , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int"+    , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String"+    ]++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\"]"+    ]+++queryTest :: Test+queryTest = testGroup "query"+    [ queryFirstTest+    , queryOneTest+    , queryOptionTest+    , queryOptionalTest+    , queryCheckTest+    , queryManyTest+    , querySomeTest+    ]++--------------------------------------------------------------------------------+stopApp :: Application+stopApp = runIdentity . runApiary def $ do+    [capture|/a/:Int|] . action $ \i -> do+        contentType "text/plain"+        when (i == 1) $ bytes "one\n"+        if i `mod` 2 == 0 then bytes "even\n" else bytes "odd\n"+        when (i == 2) stop+        bytes "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 = runIdentity . runApiary def $ [capture|/|] $ do+    accept "application/json" . action $ bytes "json"+    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/plain"       . (\a r -> assertRequest 200 Nothing "other" a $ addA "text/plain" 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 = runIdentity . runApiary def $ 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+    , anyFilterTest+    , captureTest+    , queryTest+    , stopTest+    , acceptTest+    , multipleFilter1Test+    ]+

@@ -0,0 +1,50 @@+{-# 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,273 +1,12 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  import Test.Framework-import Test.Framework.Providers.HUnit -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.1" = r { Network.Wai.httpVersion = HTTP.http11 }-                   | v == " HTTP/1.0" = r { Network.Wai.httpVersion = HTTP.http10 }-                   | v == " HTTP/0.9" = r { Network.Wai.httpVersion = HTTP.http09 }-                   | otherwise        = error "unknown HTTP version"------------------------------------------------------------------------------------assertPlain200 :: L.ByteString -> Application -> Request -> IO ()-assertPlain200 body app req = flip runSession app $ do-    res <- request req-    assertBody body res-    assertStatus 200 res-    assertContentType "text/plain" res--assertHtml200 :: L.ByteString -> Application -> Request -> IO ()-assertHtml200 body app req = flip runSession app $ do-    res <- request req-    assertBody body res-    assertStatus 200 res-    assertContentType "text/html" res--assert404 :: Application -> Request -> IO ()-assert404 app req = flip runSession app $ do-    res <- request req-    assertBody "404 Page Notfound.\n" res-    assertStatus 404 res-    assertContentType "text/plain" res------------------------------------------------------------------------------------helloWorldApp :: Application-helloWorldApp = runApiary def $ action $ do-    contentType "text/plain"-    bytes "hello"--helloWorldAllTest :: Test-helloWorldAllTest = testGroup "helloWorld" -    [ testReq "GET /"    $ assertPlain200 "hello" helloWorldApp-    , testReq "GET /foo" $ assertPlain200 "hello" helloWorldApp-    , testReq "POST /"   $ assertPlain200 "hello" helloWorldApp-    ]------------------------------------------------------------------------------------methodFilterApp :: Application-methodFilterApp = runApiary def $ do-    method "GET" . action $ contentType "text/plain" >> bytes "GET"-    method POST  . action $ contentType "text/plain" >> bytes "POST"--methodFilterTest :: Test-methodFilterTest = testGroup "methodFilter"-    [ testReq "GET /"    $ assertPlain200 "GET" methodFilterApp-    , testReq "POST /"   $ assertPlain200 "POST" methodFilterApp-    , testReq "GET /foo" $ assertPlain200 "GET" methodFilterApp-    , testReq "DELETE /" $ assert404 methodFilterApp-    ]------------------------------------------------------------------------------------httpVersionApp :: Application-httpVersionApp = runApiary def $ 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" -    [ testReq "GET / HTTP/0.9" $ assertPlain200 "09" httpVersionApp-    , testReq "GET / HTTP/1.0" $ assertPlain200 "10" httpVersionApp-    , testReq "GET / HTTP/1.1" $ assertPlain200 "11" httpVersionApp-    ]------------------------------------------------------------------------------------rootFilterApp :: Application-rootFilterApp = runApiary def .  root . action $ do-    contentType "text/html"-    bytes "root"--rootFilterTest :: Test-rootFilterTest = testGroup "rootFilter"-    [ testReq "GET /"           $ assertHtml200 "root" rootFilterApp-    , testReq "POST /"          $ assertHtml200 "root" rootFilterApp-    , testReq "GET /neko"       $ assert404 rootFilterApp-    , testReq "GET /index.html" $ assertHtml200 "root" rootFilterApp-    ]-----------------------------------------------------------------------------------anyFilterApp :: Application-anyFilterApp = runApiary def $ [capture|/test|] . anyPath . action $ do-    contentType "text/plain"-    bytes "hello"--anyFilterTest :: Test-anyFilterTest = testGroup "anyPath"-    [ testReq "GET /"          $ assert404 anyFilterApp-    , testReq "GET /test"      $ assertPlain200 "hello" anyFilterApp-    , testReq "POST /test/foo" $ assertPlain200 "hello" anyFilterApp-    ]------------------------------------------------------------------------------------captureApp :: Application-captureApp = runApiary def $ do-    [capture|/foo|]  . action $ contentType "text/plain" >> bytes "foo"-    [capture|/:Int|] . method GET . action $ \i -> contentType "text/plain" >> bytes "Int " >> showing i-    [capture|/:Double|] . action $ \i -> contentType "text/plain" >> bytes "Double " >> showing i-    [capture|/bar/:L.ByteString/:Int|] . action $ \s i -> contentType "text/plain" >> lazyBytes s >> char ' ' >> showing i-    [capture|/:L.ByteString|] . action $ \s -> contentType "text/plain" >> bytes "fall " >> lazyBytes s--captureTest :: Test-captureTest = testGroup "capture"-    [ testReq "GET /foo" $ assertPlain200 "foo" captureApp-    , testReq "GET /12"   $ assertPlain200 "Int 12" captureApp-    , testReq "GET /12.4" $ assertPlain200 "Double 12.4" captureApp-    , testReq "POST /12"  $ assertPlain200 "Double 12.0" captureApp-    , testReq "GET /bar"  $ assertPlain200 "fall bar" captureApp-    , testReq "GET /baz"  $ assertPlain200 "fall baz" captureApp-    , testReq "GET /bar/nyan/12"       $ assertPlain200 "nyan 12" captureApp-    , testReq "GET /bar/nyan/12/other" $ assert404 captureApp-    ]------------------------------------------------------------------------------------queryApp f g h = runApiary def $ do-    _ <- (f "foo" pInt)             . action $ \i -> contentType "text/plain" >> bytes "foo Int " >> showing i-    _ <- (g "foo" pString)          . action $ \i -> contentType "text/plain" >> bytes "foo String " >> showing i-    (h "foo" (pMaybe pString)) . action $ \i -> contentType "text/plain" >> bytes "foo Maybe String " >> showing i--queryCheckApp :: Application-queryCheckApp = runApiary def $ do-    ("foo" ?: pInt)           . action $ contentType "text/plain" >> bytes "foo Int"-    ("foo" ?: pString)        . action $ contentType "text/plain" >> bytes "foo String"-    ("foo" ?: pMaybe pString) . action $ contentType "text/plain" >> bytes "foo Maybe String"--queryFirstTest :: Test-queryFirstTest = testGroup "First"-    [ testReq "GET /" $ assert404 app-    , testReq "GET /?foo" $ assertPlain200 "foo Maybe String Nothing" app-    , testReq "GET /?foo&foo=3" $ assertPlain200 "foo Maybe String Nothing" app-    , testReq "GET /?foo=12" $ assertPlain200 "foo Int 12" app-    , testReq "GET /?foo=a" $ assertPlain200 "foo String \"a\"" app-    , testReq "GET /?foo=12&foo=23" $ assertPlain200 "foo Int 12" app-    , testReq "GET /?foo=12&foo=b" $ assertPlain200 "foo Int 12" app-    ]-  where app = queryApp (=:) (=:) (=:)--queryOneTest :: Test-queryOneTest = testGroup "One"-    [ testReq "GET /" $ assert404 app-    , testReq "GET /?foo" $ assertPlain200 "foo Maybe String Nothing" app-    , testReq "GET /?foo&foo=3" $ assert404 app-    , testReq "GET /?foo=12" $ assertPlain200 "foo Int 12" app-    , testReq "GET /?foo=a" $ assertPlain200 "foo String \"a\"" app-    , testReq "GET /?foo=12&foo=23" $ assert404 app-    , testReq "GET /?foo=12&foo=b" $ assert404 app-    ]-  where app = queryApp (=!:) (=!:) (=!:)--queryOptionTest :: Test-queryOptionTest = testGroup "Option"-    [ testReq "GET /" $ assertPlain200 "foo Int Nothing" app-    , testReq "GET /?foo" $ assertPlain200 "foo Maybe String Just Nothing" app-    , testReq "GET /?foo&foo=3" $ assertPlain200 "foo Maybe String Just Nothing" app-    , testReq "GET /?foo=12" $ assertPlain200 "foo Int Just 12" app-    , testReq "GET /?foo=a" $ assertPlain200 "foo String Just \"a\"" app-    , testReq "GET /?foo=12&foo=23" $ assertPlain200 "foo Int Just 12" app-    , testReq "GET /?foo=12&foo=b" $ assertPlain200 "foo String Just \"12\"" app-    ]-  where app = queryApp (=?:) (=?:) (=?:)--queryCheckTest :: Test-queryCheckTest = testGroup "Check"-    [ testReq "GET /" $ assert404 app-    , testReq "GET /?foo" $ assertPlain200 "foo Maybe String" app-    , testReq "GET /?foo&foo=3" $ assertPlain200 "foo Maybe String" app-    , testReq "GET /?foo=12" $ assertPlain200 "foo Int" app-    , testReq "GET /?foo=a" $ assertPlain200 "foo String" app-    , testReq "GET /?foo=12&foo=23" $ assertPlain200 "foo Int" app-    , testReq "GET /?foo=12&foo=b" $ assertPlain200 "foo String" app-    ]-  where app = queryCheckApp--queryManyTest :: Test-queryManyTest = testGroup "Many"-    [ testReq "GET /" $ assertPlain200 "foo Int []" app-    , testReq "GET /?foo" $ assertPlain200 "foo Maybe String [Nothing]" app-    , testReq "GET /?foo&foo=3" $ assertPlain200 "foo Maybe String [Nothing,Just \"3\"]" app-    , testReq "GET /?foo=12" $ assertPlain200 "foo Int [12]" app-    , testReq "GET /?foo=a" $ assertPlain200 "foo String [\"a\"]" app-    , testReq "GET /?foo=12&foo=23" $ assertPlain200 "foo Int [12,23]" app-    , testReq "GET /?foo=12&foo=b" $ assertPlain200 "foo String [\"12\",\"b\"]" app-    ]-  where app = queryApp (=*:) (=*:) (=*:)--querySomeTest :: Test-querySomeTest = testGroup "Some"-    [ testReq "GET /" $ assert404 app-    , testReq "GET /?foo" $ assertPlain200 "foo Maybe String [Nothing]" app-    , testReq "GET /?foo&foo=3" $ assertPlain200 "foo Maybe String [Nothing,Just \"3\"]" app-    , testReq "GET /?foo=12" $ assertPlain200 "foo Int [12]" app-    , testReq "GET /?foo=a" $ assertPlain200 "foo String [\"a\"]" app-    , testReq "GET /?foo=12&foo=23" $ assertPlain200 "foo Int [12,23]" app-    , testReq "GET /?foo=12&foo=b" $ assertPlain200 "foo String [\"12\",\"b\"]" app-    ]-  where app = queryApp (=+:) (=+:) (=+:)---queryTest :: Test-queryTest = testGroup "query"-    [ queryFirstTest-    , queryOneTest-    , queryOptionTest-    , queryCheckTest-    , queryManyTest-    , querySomeTest-    ]------------------------------------------------------------------------------------multipleFilter1App :: Application-multipleFilter1App = runApiary def $ 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-    ]-----------------------------------------------------------------------------------+import Application+import Method  main :: IO ()-main = defaultMain -    [ helloWorldAllTest-    , methodFilterTest-    , httpVersionTest-    , rootFilterTest-    , anyFilterTest-    , captureTest-    , queryTest-    , multipleFilter1Test+main = defaultMain+    [ methodTests+    , applicationTests     ]