apiary 0.11.3 → 0.12.0

raw patch · 14 files changed

+575/−243 lines, 14 filesdep +blaze-htmlPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-html

API changes (from Hackage documentation)

Files

• apiary.cabal +35/−31
• src/Control/Monad/Apiary.hs +4/−0
• src/Control/Monad/Apiary/Action.hs +4/−2
• src/Control/Monad/Apiary/Action/Internal.hs +47/−26
• src/Control/Monad/Apiary/Filter.hs +54/−34
• src/Control/Monad/Apiary/Filter/Internal.hs +8/−8
• src/Control/Monad/Apiary/Filter/Internal/Capture.hs +19/−20
• src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +13/−3
• src/Control/Monad/Apiary/Filter/Internal/Strategy.hs +31/−15
• src/Control/Monad/Apiary/Internal.hs +98/−54
• src/Data/Apiary/Document.hs +159/−0
• src/Data/Apiary/Param.hs +102/−47
• src/Web/Apiary.hs +1/−2
• src/Web/Apiary/TH.hs +0/−1

@@ -1,8 +1,8 @@ name:                apiary-version:             0.11.3-synopsis:            Simple web framework inspired by scotty.+version:             0.12.0+synopsis:            Simple and type safe web framework that can be automatically generate API document. description:-  Simple web framework inspired by scotty.+  Simple and type safe web framework that can be automatically generate API document.   .   @   &#123;-&#35; LANGUAGE QuasiQuotes &#35;-&#125;@@ -35,6 +35,8 @@   .     * type safe route filter.   .+    * auto generate API documentation(https://github.com/philopon/apiary/blob/master/examples/api.hs>).+  .   more examples: <https://github.com/philopon/apiary/blob/master/examples/>  license:             MIT@@ -66,6 +68,7 @@                         Data.Apiary.SList                        Data.Apiary.Param+                       Data.Apiary.Document    other-modules:       Control.Monad.Apiary.Internal                        Control.Monad.Apiary.Action.Internal@@ -80,33 +83,34 @@                       , Rank2Types                        -  build-depends:       base              >=4.6 && <4.8-                     , template-haskell  >=2.8 && <2.10-                     , mtl               >=2.1 && <2.3-                     , monad-control     >=0.3 && <0.4-                     , transformers-base >=0.4 && <0.5+  build-depends:       base                 >=4.6   && <4.8+                     , template-haskell     >=2.8   && <2.10+                     , mtl                  >=2.1   && <2.3+                     , monad-control        >=0.3   && <0.4+                     , transformers-base    >=0.4   && <0.5 -                     , text               >=1.1 && <1.2-                     , bytestring         >=0.10 && <0.11-                     , blaze-builder      >=0.3 && <0.4-                     , data-default-class >=0.0 && <0.1-                     , reflection         >=1.4 && <1.5+                     , text                 >=1.1   && <1.2+                     , bytestring           >=0.10  && <0.11+                     , blaze-builder        >=0.3   && <0.4+                     , data-default-class   >=0.0   && <0.1+                     , reflection           >=1.4   && <1.5 -                     , http-types        >=0.8 && <0.9-                     , mime-types        >=0.1 && <0.2-                     , exceptions        >=0.6 && <0.7+                     , http-types           >=0.8   && <0.9+                     , mime-types           >=0.1   && <0.2+                     , exceptions           >=0.6   && <0.7+                     , blaze-html           >=0.7   && <0.8    if impl(ghc < 7.8)-    build-depends:     tagged             >=0.7 && <0.8+    build-depends:     tagged               >=0.7   && <0.8    if flag(wai3)-    build-depends:     wai               >=3.0 && <3.1-                     , wai-extra         >=3.0 && <3.1+    build-depends:     wai                  >=3.0   && <3.1+                     , wai-extra            >=3.0   && <3.1     cpp-options:       -DWAI3   else-    build-depends:     wai               >=2.1 && <2.2-                     , wai-extra         >=2.1 && <2.2-                     , conduit           >=1.1 && <1.2+    build-depends:     wai                  >=2.1   && <2.2+                     , wai-extra            >=2.1   && <2.2+                     , conduit              >=1.1   && <1.2    hs-source-dirs:      src   ghc-options:         -O2 -Wall@@ -115,18 +119,18 @@ test-suite test-framework   main-is:             main.hs   type:                exitcode-stdio-1.0-  build-depends:       base                 >=4.6 && <4.8-                     , test-framework       >=0.8 && <0.9-                     , test-framework-hunit >=0.3 && <0.4+  build-depends:       base                 >=4.6   && <4.8+                     , 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+                     , bytestring           >=0.10  && <0.11+                     , http-types           >=0.8   && <0.9   if flag(wai3)-    build-depends:     wai               >=3.0 && <3.1-                     , wai-extra         >=3.0 && <3.1+    build-depends:     wai                  >=3.0   && <3.1+                     , wai-extra            >=3.0   && <3.1   else-    build-depends:     wai               >=2.1 && <2.2-                     , wai-test          >=2.0 && <2.1+    build-depends:     wai                  >=2.1   && <2.2+                     , wai-test             >=2.0   && <2.1    hs-source-dirs:      test   ghc-options:         -O2 -Wall -fno-warn-missing-signatures

@@ -2,10 +2,14 @@     ( ApiaryT, Apiary     , runApiary     , runApiaryT+    , runApiaryT'     -- * getter     , apiaryConfig     -- * execute action     , action, action'+    -- * API documentation+    , group+    , document     -- * deprecated     , actionWithPreAction     ) where

@@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-}  module Control.Monad.Apiary.Action -    (-      ActionT+    ( ActionT     , ApiaryConfig(..)     -- * actions     , stop, stopWith@@ -17,8 +16,10 @@     , status     -- *** response header     , addHeader, setHeaders, modifyHeader+    , ContentType     , contentType     -- *** response body+    , File(..)     , file     , file'     , builder@@ -42,6 +43,7 @@  import Control.Monad.Apiary.Action.Internal import Data.Default.Class+import Data.Apiary.Param import Network.HTTP.Types.Status hiding (mkStatus)  #ifdef WAI3

@@ -8,6 +8,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}  module Control.Monad.Apiary.Action.Internal where @@ -18,12 +20,17 @@ import Control.Monad.Reader import Control.Monad.Catch import Control.Monad.Trans.Control+ import Network.Wai-import Network.Wai.Parse+import qualified Network.Wai.Parse as P import Network.Mime-import Data.Default.Class import Network.HTTP.Types++import Data.Apiary.Param+import Data.Apiary.Document+import Data.Default.Class import Blaze.ByteString.Builder+import Text.Blaze.Html.Renderer.Utf8 import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Text as T@@ -34,41 +41,52 @@  data ApiaryConfig = ApiaryConfig     { -- | call when no handler matched.-      notFound      :: Application+      notFound       :: Application       -- | used unless call 'status' function.-    , defaultStatus :: Status+    , defaultStatus  :: Status       -- | initial headers.-    , defaultHeader :: ResponseHeaders+    , defaultHeader  :: ResponseHeaders       -- | used by 'Control.Monad.Apiary.Filter.root' filter.-    , rootPattern   :: [S.ByteString]-    , mimeType      :: FilePath -> S.ByteString+    , rootPattern    :: [S.ByteString]+    , mimeType       :: FilePath -> S.ByteString+    , documentAction :: Documents -> ActionT IO ()     } +defaultDocument :: Monad m => S.ByteString -> Documents -> ActionT m ()+defaultDocument r d = do+    p <- rawPathInfo <$> getRequest+    guard $ p == r+    contentType "text/html"+    builder . renderHtmlBuilder $ defaultDocumentToHtml d+ defNotFound :: Application #ifdef WAI3-defNotFound _ f = f $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"+defNotFound _ f = f      $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n" #else-defNotFound _ = return $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"+defNotFound _   = return $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n" #endif  instance Default ApiaryConfig where     def = ApiaryConfig -        { notFound      = defNotFound-        , defaultStatus = ok200-        , defaultHeader = []-        , rootPattern   = ["", "/", "/index.html", "/index.htm"]-        , mimeType      = defaultMimeLookup . T.pack+        { notFound       = defNotFound+        , defaultStatus  = ok200+        , defaultHeader  = []+        , rootPattern    = ["", "/", "/index.html", "/index.htm"]+        , mimeType       = defaultMimeLookup . T.pack+        , documentAction = defaultDocument "/api/document"         } -data ActionState -    = ActionState-        { actionResponse :: Response-        , actionStatus   :: Status-        , actionHeaders  :: ResponseHeaders-        , actionReqBody  :: Maybe ([Param], [File L.ByteString])-        , actionPathInfo :: [T.Text]-        }+convFile :: (S.ByteString, P.FileInfo L.ByteString) -> File+convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent +data ActionState = ActionState+    { actionResponse :: Response+    , actionStatus   :: Status+    , actionHeaders  :: ResponseHeaders+    , actionReqBody  :: Maybe ([Param], [File])+    , actionPathInfo :: [T.Text]+    }+ initialState :: ApiaryConfig -> Request -> ActionState initialState conf req = ActionState     { actionResponse = responseLBS (defaultStatus conf) (defaultHeader conf) ""@@ -217,11 +235,12 @@ getRequest :: Monad m => ActionT m Request getRequest = ActionT $ \_ r s c -> c r s -getRequestBody :: MonadIO m => ActionT m ([Param], [File L.ByteString])+getRequestBody :: MonadIO m => ActionT m ([Param], [File]) getRequestBody = ActionT $ \_ r s c -> case actionReqBody s of     Just b  -> c b s     Nothing -> do-        b <- liftIO $ parseRequestBody lbsBackEnd r+        (p,f) <- liftIO $ P.parseRequestBody P.lbsBackEnd r+        let b = (p, map convFile f)         c b s { actionReqBody = Just b }  -- | parse request body and return params. since 0.9.0.0.@@ -229,7 +248,7 @@ getReqParams = fst <$> getRequestBody  -- | parse request body and return files. since 0.9.0.0.-getReqFiles :: MonadIO m => ActionT m [File L.ByteString]+getReqFiles :: MonadIO m => ActionT m [File] getReqFiles = snd <$> getRequestBody  getConfig :: Monad m => ActionT m ApiaryConfig@@ -261,9 +280,11 @@ setHeaders :: Monad m => ResponseHeaders -> ActionT 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 => S.ByteString -> ActionT m ()+contentType :: Monad m => ContentType -> ActionT m () contentType c = modifyHeader     (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h) 

@@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}  module Control.Monad.Apiary.Filter (     -- * filters@@ -22,6 +23,7 @@     , Capture.fetch      -- ** query matcher+    , QueryKey(..)     , query     -- *** specified operators     , (=:), (=!:), (=?:), (?:), (=*:), (=+:)@@ -51,11 +53,15 @@ import qualified Network.HTTP.Types as HT import Network.HTTP.Types (StdMethod(..)) import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as SC import Data.Proxy+import Data.String import Data.Reflection+import Text.Blaze.Html  import Data.Apiary.SList import Data.Apiary.Param+import Data.Apiary.Document  import Control.Monad.Apiary.Action.Internal import Control.Monad.Apiary.Filter.Internal@@ -66,40 +72,49 @@ import Control.Monad.Apiary.Internal  -- | filter by HTTP method. since 0.1.0.0.-method :: (Functor n, Monad n) => HT.Method -> ApiaryT c n m a -> ApiaryT c n m a-method m = function_ ((m ==) . requestMethod)+method :: Monad n => HT.Method -> ApiaryT c n m a -> ApiaryT c n m a+method m = function_ (DocMethod m) ((m ==) . requestMethod)  -- | filter by HTTP method using StdMethod. since 0.1.0.0.-stdMethod :: (Functor n, Monad n) => StdMethod -> ApiaryT c n m a -> ApiaryT c n m a+stdMethod :: Monad n => StdMethod -> ApiaryT c n m a -> ApiaryT c n m a stdMethod = method . HT.renderStdMethod  -- | filter by ssl accessed. since 0.1.0.0.-ssl :: (Functor n, Monad n) => ApiaryT c n m a -> ApiaryT c n m a-ssl = function_ isSecure+ssl :: Monad n => ApiaryT c n m a -> ApiaryT c n m a+ssl = function_ id isSecure  -- | http version filter. since 0.5.0.0.-httpVersion :: (Functor n, Monad n) => HT.HttpVersion-            -> ApiaryT c n m b -> ApiaryT c n m b-httpVersion v = function_ $ (v ==) . Wai.httpVersion+httpVersion :: Monad n => HT.HttpVersion -> ApiaryT c n m b -> ApiaryT c n m b+httpVersion v = function_ id $ (v ==) . Wai.httpVersion  -- | http/0.9 only accepted fiter. since 0.5.0.0.-http09 :: (Functor n, Monad n) => ApiaryT c n m b -> ApiaryT c n m b+http09 :: Monad n => ApiaryT c n m b -> ApiaryT c n m b http09 = Control.Monad.Apiary.Filter.httpVersion HT.http09  -- | http/1.0 only accepted fiter. since 0.5.0.0.-http10 :: (Functor n, Monad n) => ApiaryT c n m b -> ApiaryT c n m b+http10 :: Monad n => ApiaryT c n m b -> ApiaryT c n m b http10 = Control.Monad.Apiary.Filter.httpVersion HT.http10  -- | http/1.1 only accepted fiter. since 0.5.0.0.-http11 :: (Functor n, Monad n) => ApiaryT c n m b -> ApiaryT c n m b+http11 :: Monad n => ApiaryT c n m b -> ApiaryT c n m b http11 = Control.Monad.Apiary.Filter.httpVersion HT.http11  -- | filter by 'Control.Monad.Apiary.Action.rootPattern' of 'Control.Monad.Apiary.Action.ApiaryConfig'.-root :: (Functor n, Monad n) => ApiaryT c n m b -> ApiaryT c n m b+root :: Monad n => ApiaryT c n m b -> ApiaryT c n m b root m = do     rs <- rootPattern `liftM` apiaryConfig-    function_ (\r -> rawPathInfo r `elem` rs) m+    function_ DocRoot (\r -> rawPathInfo r `elem` rs) m +data QueryKey = QueryKey+    { queryKey  :: S.ByteString+    , queryDesc :: Maybe Html+    }++instance IsString QueryKey where+    fromString s = case break (== ':') s of+        (k, []) -> QueryKey (SC.pack k) Nothing+        (k, d)  -> QueryKey (SC.pack k) (Just . toHtml $ tail d)+ -- | low level query getter. since 0.5.0.0. -- -- @@@ -114,25 +129,30 @@ -- query "key" (Proxy :: Proxy ('Many' String) -- get all \'key\' query parameter as String. -- @ query :: forall a as w n m b proxy. -      (ReqParam a, Strategy.Strategy w, Functor n, MonadIO n)-      => S.ByteString+      (ReqParam a, Strategy.Strategy w, MonadIO n)+      => QueryKey       -> proxy (w a)       -> ApiaryT (Strategy.SNext w as a) n m b       -> ApiaryT as n m b-query key p = focus $ \l -> do-    r     <- getRequest-    (q,f) <- getRequestBody+query QueryKey{..} p =+    focus doc $ \l -> do+        r     <- getRequest+        (q,f) <- getRequestBody -    maybe mzero return $-        Strategy.readStrategy id ((key ==) . fst) p -        (reqParams (Proxy :: Proxy a) r q f) l+        maybe mzero return $+            Strategy.readStrategy id ((queryKey ==) . fst) p +            (reqParams (Proxy :: Proxy a) r q f) l+  where+    doc = case queryDesc of+        Nothing -> id+        Just h  -> DocQuery queryKey (Strategy.strategyRep (Proxy :: Proxy w)) (reqParamRep (Proxy :: Proxy a)) h  -- | get first matched paramerer. since 0.5.0.0. -- -- @ -- "key" =: pInt == query "key" (pFirst pInt) == query "key" (Proxy :: Proxy (First Int)) -- @-(=:) :: (Functor n, MonadIO n, ReqParam a) => S.ByteString -> proxy a +(=:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a       -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b k =: t = query k (pFirst t) @@ -143,7 +163,7 @@ -- @ -- "key" =: pInt == query "key" (pOne pInt) == query "key" (Proxy :: Proxy (One Int)) -- @-(=!:) :: (Functor n, MonadIO n, ReqParam a) => S.ByteString -> proxy a +(=!:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a        -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b k =!: t = query k (pOne t) @@ -154,7 +174,7 @@ -- @ -- "key" =: pInt == query "key" (pOption pInt) == query "key" (Proxy :: Proxy (Option Int)) -- @-(=?:) :: (Functor n, MonadIO n, ReqParam a) => S.ByteString -> proxy a +(=?:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a        -> ApiaryT (Snoc as (Maybe a)) n m b -> ApiaryT as n m b k =?: t = query k (pOption t) @@ -165,7 +185,7 @@ -- @ -- "key" =: pInt == query "key" (pCheck pInt) == query "key" (Proxy :: Proxy (Check Int)) -- @-(?:) :: (Functor n, MonadIO n, ReqParam a) => S.ByteString -> proxy a +(?:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a       -> ApiaryT as n m b -> ApiaryT as n m b k ?: t = query k (pCheck t) @@ -174,7 +194,7 @@ -- @ -- "key" =: pInt == query "key" (pMany pInt) == query "key" (Proxy :: Proxy (Many Int)) -- @-(=*:) :: (Functor n, MonadIO n, ReqParam a) => S.ByteString -> proxy a +(=*:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a        -> ApiaryT (Snoc as [a]) n m b -> ApiaryT as n m b k =*: t = query k (pMany t) @@ -183,7 +203,7 @@ -- @ -- "key" =: pInt == query "key" (pSome pInt) == query "key" (Proxy :: Proxy (Some Int)) -- @-(=+:) :: (Functor n, MonadIO n, ReqParam a) => S.ByteString -> proxy a +(=+:) :: (MonadIO n, ReqParam a) => QueryKey -> proxy a        -> ApiaryT (Snoc as [a]) n m b -> ApiaryT as n m b k =+: t = query k (pSome t) @@ -193,17 +213,17 @@ -- hasQuery q = 'query' q (Proxy :: Proxy ('Check' ())) -- @ ---hasQuery :: (Functor n, MonadIO n) => S.ByteString -> ApiaryT c n m a -> ApiaryT c n m a+hasQuery :: (MonadIO n) => QueryKey -> ApiaryT c n m a -> ApiaryT c n m a hasQuery q = query q (Proxy :: Proxy (Strategy.Check ()))  --------------------------------------------------------------------------------  -- | check whether to exists specified header or not. since 0.6.0.0.-hasHeader :: (Functor n, Monad n) => HT.HeaderName -> ApiaryT as n m b -> ApiaryT as n m b+hasHeader :: Monad n => HT.HeaderName -> ApiaryT as n m b -> ApiaryT as n m b hasHeader n = header' pCheck ((n ==) . fst)  -- | check whether to exists specified valued header or not. since 0.6.0.0.-eqHeader :: (Functor n, Monad n)+eqHeader :: Monad n          => HT.HeaderName           -> S.ByteString  -- ^ header value          -> ApiaryT as n m b@@ -211,12 +231,12 @@ eqHeader k v = header' pCheck (\(k',v') -> k == k' && v == v')  -- | filter by header and get first. since 0.6.0.0.-header :: (Functor n, Monad n) => HT.HeaderName+header :: Monad n => HT.HeaderName        -> ApiaryT (Snoc as S.ByteString) n m b -> ApiaryT as n m b header n = header' pFirst ((n ==) . fst)  -- | filter by headers up to 100 entries. since 0.6.0.0.-headers :: (Functor n, Monad n) => HT.HeaderName+headers :: Monad n => HT.HeaderName         -> ApiaryT (Snoc as [S.ByteString]) n m b -> ApiaryT as n m b headers n = header' limit100 ((n ==) . fst)   where@@ -224,10 +244,10 @@     limit100 _ = Proxy  -- | low level header filter. since 0.6.0.0.-header' :: (Strategy.Strategy w, Functor n, Monad n)+header' :: (Strategy.Strategy w, Monad n)         => (forall x. Proxy x -> Proxy (w x))         -> (HT.Header -> Bool)         -> ApiaryT (Strategy.SNext w as S.ByteString) n m b         -> ApiaryT as n m b-header' pf kf = function $ \l r ->+header' pf kf = function id $ \l r ->     Strategy.readStrategy Just kf (pf pByteString) (requestHeaders r) l

@@ -7,22 +7,22 @@ import Control.Monad.Apiary.Action import Network.Wai import Data.Apiary.SList+import Data.Apiary.Document  -- | low level filter function.-function :: (Functor n, Monad n) => (SList c -> Request -> Maybe (SList c'))+function :: Monad n => (Doc -> Doc)+         -> (SList c -> Request -> Maybe (SList c'))          -> ApiaryT c' n m b -> ApiaryT c n m b-function f = focus $ \c -> getRequest >>= \r -> case f c r of+function d f = focus d $ \c -> getRequest >>= \r -> case f c r of     Nothing -> mzero     Just c' -> return c'  -- | filter and append argument.-function' :: (Functor n, Monad n) => (Request -> Maybe a)+function' :: Monad n => (Doc -> Doc) -> (Request -> Maybe a)           -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b-function' f = function $ \c r -> sSnoc c `fmap` f r+function' d f = function d $ \c r -> sSnoc c `fmap` f r  -- | filter only(not modify arguments).-function_ :: (Functor n, Monad n) => (Request -> Bool) +function_ :: Monad n => (Doc -> Doc) -> (Request -> Bool)            -> ApiaryT c n m b -> ApiaryT c n m b-function_ f = function $ \c r -> if f r then Just c else Nothing--+function_ d f = function d $ \c r -> if f r then Just c else Nothing

@@ -16,37 +16,36 @@ import Control.Applicative import Control.Monad import qualified Data.Text as T+import Text.Blaze.Html+ import Data.Apiary.Param import Data.Apiary.SList+import Data.Apiary.Document  import Control.Monad.Apiary.Action.Internal-import Control.Monad.Apiary-import Control.Monad.Apiary.Filter.Internal+import Control.Monad.Apiary.Internal --- | check first path and drill down. since v0.11.0.-path :: (Functor n, Monad n) -     => T.Text -> ApiaryT c n m a -> ApiaryT c n m a-path p = focus $ \l -> l <$ path'+-- | 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 p = focus (DocPath p) $ \l -> l <$ path'   where     path' = liftM actionPathInfo getState >>= \case         c:_ | c == p -> modifyState (\s -> s {actionPathInfo = tail $ actionPathInfo s})-        _            -> empty+        _            -> mzero --- | check consumed pathes. since v0.11.1.-endPath :: (Functor n, Monad n) => ApiaryT c n m a -> ApiaryT c n m a-endPath = focus $ \l -> l <$ end+-- | check consumed pathes. since 0.11.1.+endPath :: Monad n => ApiaryT c n m a -> ApiaryT c n m a+endPath = focus id $ \l -> l <$ end   where     end = liftM actionPathInfo getState >>= \case         [] -> return ()-        _  -> empty+        _  -> mzero --- | get first path and drill down. since v0.11.0.-fetch :: (Path a, Functor n, Monad n)-      => proxy a -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b-fetch p = focus $ \l -> liftM actionPathInfo getState >>= \case-    []  -> empty+-- | get first path and drill down. since 0.11.0.+fetch :: (Path a, Monad n) => proxy a -> Maybe Html -> ApiaryT (Snoc as a) n m b -> ApiaryT as n m b+fetch p h = focus (DocFetch (pathRep p) h) $ \l -> liftM actionPathInfo getState >>= \case+    []  -> mzero     c:_ -> case readPathAs p c of-        Nothing -> empty-        Just r  -> do-            modifyState (\s -> s { actionPathInfo = tail $ actionPathInfo s})-            return (sSnoc l r)+        Nothing -> mzero+        Just r  -> sSnoc l r <$+            modifyState (\s -> s {actionPathInfo = tail $ actionPathInfo s})

@@ -17,12 +17,22 @@ splitPath :: String -> [String] splitPath = map T.unpack . T.splitOn "/" . T.pack +description :: Monad m => String -> m (String, Maybe String)+description s = case break (== '(') s of+    (t, []) -> return (t, Nothing)+    (t, st) -> case break (== ')') st of+        (_:b, ")") -> return (t, Just b)+        (_, _)     -> fail "capture: syntax error." + mkCap :: [String] -> ExpQ mkCap [] = [|Capture.endPath|] mkCap ((':':tyStr):as) = do-    -- ty <- lookupTypeName tyStr >>= maybe (fail "") return-    let ty = mkName tyStr-    [|Capture.fetch (Proxy :: Proxy $(conT ty)) . $(mkCap as) |]+    (t, mbd) <- description tyStr+    ty <- lookupTypeName t >>= maybe (fail $ t ++ " not found.") return+    let d = case mbd of+            Nothing -> [|Nothing|]+            Just h  -> [|Just $(stringE h)|]+    [|Capture.fetch (Proxy :: Proxy $(conT ty)) $d . $(mkCap as)|] mkCap (eq:as) = do     [|(Capture.path $(stringE eq)) . $(mkCap as) |] 

@@ -3,32 +3,41 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE CPP #-}  module Control.Monad.Apiary.Filter.Internal.Strategy where  import Data.Apiary.SList+import qualified Data.Text as T+import Data.Apiary.Document +import Data.Typeable import Data.Maybe-import Data.Proxy import Data.Reflection+#if __GLASGOW_HASKELL__ < 707+import Data.Proxy+#endif  class Strategy (w :: * -> *) where-  type SNext w (as :: [*]) a  :: [*]-  readStrategy :: (v -> Maybe a)-               -> ((k,v) -> Bool)-               -> proxy (w a)-               -> [(k, v)]-               -> SList as -               -> Maybe (SList (SNext w as a))+    type SNext w (as :: [*]) a  :: [*]+    readStrategy :: (v -> Maybe a)+                 -> ((k,v) -> Bool)+                 -> proxy (w a)+                 -> [(k, v)]+                 -> SList as +                 -> Maybe (SList (SNext w as a))+    strategyRep :: proxy w -> StrategyRep  getQuery :: (v -> Maybe a) -> proxy (w a) -> ((k,v) -> Bool) -> [(k, v)] -> [Maybe a] getQuery readf _ kf = map readf . map snd . filter kf  -- | get first matched key( [1,) params to Type.). since 0.5.0.0.-data Option a+data Option a deriving Typeable instance Strategy Option where     type SNext Option as a = Snoc as (Maybe a)     readStrategy rf k p q l =@@ -38,9 +47,10 @@            else Just . sSnoc l $ case catMaybes rs of                []  -> Nothing                a:_ -> Just a+    strategyRep _ = StrategyRep "optional"  -- | get first matched key ( [0,) params to Maybe Type.) since 0.5.0.0.-data First a+data First a deriving Typeable instance Strategy First where     type SNext First as a = Snoc as a     readStrategy rf k p q l =@@ -50,9 +60,10 @@            else case catMaybes rs of                [] -> Nothing                a:_ -> Just $ sSnoc l a+    strategyRep _ = StrategyRep "first"  -- | get key ( [1] param to Type.) since 0.5.0.0.-data One a+data One a deriving Typeable instance Strategy One where     type SNext One as a = Snoc as a     readStrategy rf k p q l =@@ -62,9 +73,10 @@            else case catMaybes rs of                [a] -> Just $ sSnoc l a                _   -> Nothing+    strategyRep _ = StrategyRep "one"  -- | get parameters ( [0,) params to [Type] ) since 0.5.0.0.-data Many a+data Many a deriving Typeable instance Strategy Many where     type SNext Many as a = Snoc as [a]     readStrategy rf k p q l =@@ -72,9 +84,10 @@         in if any isNothing rs            then Nothing            else Just $ sSnoc l (catMaybes rs)+    strategyRep _ = StrategyRep "many"  -- | get parameters ( [1,) params to [Type] ) since 0.5.0.0.-data Some a+data Some a deriving Typeable instance Strategy Some where     type SNext Some as a = Snoc as [a]     readStrategy rf k p q l =@@ -84,9 +97,10 @@            else case catMaybes rs of                [] -> Nothing                as -> Just $ sSnoc l as+    strategyRep _ = StrategyRep "some"  -- | get parameters with upper limit ( [1,n] to [Type]) since 0.6.0.0.-data LimitSome u a+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 =@@ -96,6 +110,7 @@            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@@ -104,7 +119,7 @@     asTyInt _ = Proxy  -- | type check ( [0,) params to No argument ) since 0.5.0.0.-data Check a+data Check a deriving Typeable instance Strategy Check where     type SNext Check as a = as     readStrategy rf k p q l =@@ -114,6 +129,7 @@            else case  catMaybes rs of                [] -> Nothing                _  -> Just l+    strategyRep _ = StrategyRep "check"  -- | construct Option proxy. since 0.5.1.0. pOption :: proxy a -> Proxy (Option a)

@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}  {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-}@@ -22,14 +23,35 @@ import Control.Monad.Trans.Control import Control.Monad.Base import Data.Apiary.SList+import Data.Apiary.Document+import Data.Monoid+import qualified Data.Text as T  import Control.Monad.Apiary.Action.Internal +data ApiaryReader n c = ApiaryReader+    { readerFilter :: ActionT n (SList c)+    , readerConfig :: ApiaryConfig+    , readerDoc    :: Doc -> Doc+    }++data ApiaryWriter n = ApiaryWriter+    { writerHandler :: ActionT n ()+    , writerDoc     :: [Doc]+    }++instance Monad n => Monoid (ApiaryWriter n) where+    mempty = ApiaryWriter mzero []+    ApiaryWriter ah ad `mappend` ApiaryWriter bh bd =+        ApiaryWriter (mplus ah bh) (ad <> bd)++initialReader :: Monad n => ApiaryConfig -> ApiaryReader n '[]+initialReader conf = ApiaryReader (return SNil) conf id+ -- | most generic Apiary monad. since 0.8.0.0. newtype ApiaryT c n m a = ApiaryT { unApiaryT :: forall b.-    ActionT n (SList c)-    -> ApiaryConfig-    -> (a -> ActionT n () -> m b)+    ApiaryReader n c+    -> (a -> ApiaryWriter n -> m b)     -> m b      } @@ -37,89 +59,111 @@ type Apiary c = ApiaryT c IO Identity  instance Functor (ApiaryT c n m) where-    fmap f m = ApiaryT $ \grd conf cont ->-        unApiaryT m grd conf $ \a hdr -> hdr `seq` cont (f a) hdr+    fmap f m = ApiaryT $ \rdr cont ->+        unApiaryT m rdr $ \a hdr -> hdr `seq` cont (f a) hdr -instance (Monad n, Functor n) => Applicative (ApiaryT c n m) where-    pure x = ApiaryT $ \_ _ cont -> cont x empty-    mf <*> ma = ApiaryT $ \grd conf cont ->-        unApiaryT mf grd conf $ \f hdr  ->-        unApiaryT ma grd conf $ \a hdr' ->-        let hdr'' = hdr <|> hdr'+instance Monad n => Applicative (ApiaryT c n m) where+    pure x = ApiaryT $ \_ cont -> cont x mempty+    mf <*> ma = ApiaryT $ \rdr cont ->+        unApiaryT mf rdr $ \f hdr  ->+        unApiaryT ma rdr $ \a hdr' ->+        let hdr'' = hdr <> hdr'         in hdr'' `seq` cont (f a) hdr'' -instance (Monad n, Functor n) => Monad (ApiaryT c n m) where-    return x = ApiaryT $ \_ _ cont -> cont x empty-    m >>= k = ApiaryT $ \grd conf cont ->-        unApiaryT    m  grd conf $ \a hdr  ->-        unApiaryT (k a) grd conf $ \b hdr' -> -        let hdr'' = hdr <|> hdr'+instance Monad n => Monad (ApiaryT c n m) where+    return x = ApiaryT $ \_ cont -> cont x mempty+    m >>= k = ApiaryT $ \rdr cont ->+        unApiaryT    m  rdr $ \a hdr  ->+        unApiaryT (k a) rdr $ \b hdr' -> +        let hdr'' = hdr <> hdr'         in hdr'' `seq` cont b hdr'' -instance (Functor n, Monad n) => MonadTrans (ApiaryT c n) where-    lift m = ApiaryT $ \_ _ c -> m >>= \a -> c a empty+instance Monad n => MonadTrans (ApiaryT c n) where+    lift m = ApiaryT $ \_ c -> m >>= \a -> c a mempty -instance (Functor n, Monad n, MonadIO m) => MonadIO (ApiaryT c n m) where-    liftIO m = ApiaryT $ \_ _ c -> liftIO m >>= \a -> c a empty+instance (Monad n, MonadIO m) => MonadIO (ApiaryT c n m) where+    liftIO m = ApiaryT $ \_ c -> liftIO m >>= \a -> c a mempty -instance (Functor n, Monad n, MonadBase b m) => MonadBase b (ApiaryT c n m) where-    liftBase m = ApiaryT $ \_ _ c -> liftBase m >>= \a -> c a empty+instance (Monad n, MonadBase b m) => MonadBase b (ApiaryT c n m) where+    liftBase m = ApiaryT $ \_ c -> liftBase m >>= \a -> c a mempty  apiaryT :: Monad m-        => (ActionT n (SList c) -> ApiaryConfig -> m (a, ActionT n ()))+        => (ApiaryReader n c -> m (a, ApiaryWriter n))         -> ApiaryT c n m a-apiaryT f = ApiaryT $ \grd conf cont -> f grd conf >>= \(a,w) -> cont a w+apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a,w) -> cont a w -instance (Functor n, Monad n) => MonadTransControl (ApiaryT c n) where-    newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ActionT n ()) }-    liftWith f = apiaryT $ \g c ->-        liftM (\a -> (a, empty)) -        (f $ \t -> liftM StTApiary' $ unApiaryT t g c (\a w -> return (a,w)))-    restoreT m = apiaryT $ \_ _ -> liftM unStTApiary' m+instance Monad n => MonadTransControl (ApiaryT c n) where+    newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter n) }+    liftWith f = apiaryT $ \rdr ->+        liftM (\a -> (a, mempty)) +        (f $ \t -> liftM StTApiary' $ unApiaryT t rdr (\a w -> return (a,w)))+    restoreT m = apiaryT $ \_ -> liftM unStTApiary' m -instance (Functor n, Monad n, MonadBaseControl b m) => MonadBaseControl b (ApiaryT c n m) where+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 }     liftBaseWith = defaultLiftBaseWith StMApiary'     restoreM     = defaultRestoreM   unStMApiary' +runApiaryT' :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig+            -> ApiaryT '[] n m a -> m (Application, Documents)+runApiaryT' run conf m = unApiaryT m (initialReader conf) (\_ w -> return w) >>= \wtr -> do+    let doc = docsToDocuments $ writerDoc wtr+        app = execActionT conf $ hoistActionT run (writerHandler wtr) `mplus` documentAction conf doc+    return (app, doc)+ runApiaryT :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig-            -> ApiaryT '[] n m a -> m Application-runApiaryT run conf m = unApiaryT m (return SNil) conf (\_ w -> return w) >>= \act ->-    return $ execActionT conf (hoistActionT run act)+           -> ApiaryT '[] n m a -> m Application+runApiaryT run conf m = fst `liftM` runApiaryT' run conf m  runApiary :: ApiaryConfig -> Apiary '[] a -> Application runApiary conf m = runIdentity $ runApiaryT id conf m -class MonadApiary c' m where-  foa :: (SList c -> ActionT n (SList c')) -> m a -> m a--getGuard :: (Functor n, Monad n) => ApiaryT c n m (ActionT n (SList c))-getGuard = ApiaryT $ \grd _ c -> c grd empty--apiaryConfig :: (Functor n, Monad n) => ApiaryT c n m ApiaryConfig-apiaryConfig = ApiaryT $ \_ c cont -> cont c empty+apiaryConfig :: Monad n => ApiaryT c n m ApiaryConfig+apiaryConfig = ApiaryT $ \r cont -> cont (readerConfig r) mempty -addRoute :: (Functor n, Monad n) => ActionT n () -> ApiaryT c n m ()-addRoute r = ApiaryT $ \_ _ cont -> cont () r+addRoute :: Monad n => ApiaryWriter n -> ApiaryT c n m ()+addRoute r = ApiaryT $ \_ cont -> cont () r  -- | filter by action. since 0.6.1.0.-focus :: (Functor n, Monad n) => (SList c -> ActionT n (SList c'))+focus :: Monad n => (Doc -> Doc) -> (SList c -> ActionT n (SList c'))       -> ApiaryT c' n m a -> ApiaryT c n m a-focus g m = ApiaryT $ \grd cfg cont -> unApiaryT m (grd >>= g) cfg cont+focus d g m = ApiaryT $ \rdr cont -> unApiaryT m rdr +    { readerFilter = readerFilter rdr >>= g +    , readerDoc    = readerDoc rdr . d+    } cont  -- | splice ActionT ApiaryT.-action :: (Functor n, Monad n) => Fn c (ActionT n ()) -> ApiaryT c n m ()-action a = action' $ apply a+action :: Monad n => Fn c (ActionT n ()) -> ApiaryT c n m ()+action = action' . apply +-- | API document group. since 0.12.0.0.+--+-- only top level group recognized.+group :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a+group d m = ApiaryT $ \rdr cont -> unApiaryT m rdr+    { readerDoc = readerDoc rdr . DocGroup d } cont++-- | add API document. since 0.12.0.0.+--+-- It use only filters prior document,+-- so you should be placed document directly in front of action.+document :: T.Text -> ApiaryT c n m a -> ApiaryT c n m a+document d m = ApiaryT $ \rdr cont -> unApiaryT m rdr+    { readerDoc = \_ -> readerDoc rdr (Document $ Just d) } cont+ {-# DEPRECATED actionWithPreAction "use action'" #-}--- | execute action before main action. since v0.4.2.0-actionWithPreAction :: (Functor n, Monad n) => (SList xs -> ActionT n a)+-- | execute action before main action. since 0.4.2.0+actionWithPreAction :: Monad n => (SList xs -> ActionT n a)                     -> Fn xs (ActionT n ()) -> ApiaryT xs n m () actionWithPreAction pa a = do     action' $ \c -> pa c >> apply a c +getReader :: Monad n => ApiaryT c n m (ApiaryReader n c)+getReader = ApiaryT $ \rdr cont -> cont rdr mempty+ -- | like action. but not apply arguments. since 0.8.0.0.-action' :: (Functor n, Monad n) => (SList c -> ActionT n ()) -> ApiaryT c n m ()+action' :: Monad n => (SList c -> ActionT n ()) -> ApiaryT c n m () action' a = do-    grd <- getGuard-    addRoute $ grd >>= \c -> a c+    rdr <- getReader+    addRoute $ ApiaryWriter (readerFilter rdr >>= \c -> a c) +        [readerDoc rdr $ Document Nothing]

@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Data.Apiary.Document where++import Control.Applicative+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as S+import Data.Typeable+import Data.Maybe+import Data.Apiary.Param+import qualified Network.HTTP.Types as HT+import Text.Blaze.Html+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Data.Monoid+import Data.List+import Data.Function++data StrategyRep = StrategyRep+    { strategyInfo :: T.Text }+    deriving (Show, Eq)++data Doc+    = DocPath   T.Text       Doc+    | DocRoot                Doc+    | DocFetch  TypeRep (Maybe Html) Doc+    | DocMethod HT.Method    Doc+    | DocQuery  S.ByteString StrategyRep QueryRep Html Doc+    | DocGroup  T.Text       Doc+    | Document  (Maybe T.Text)++data Route+    = Path  T.Text               Route+    | Fetch TypeRep (Maybe Html) Route+    | End++instance Eq Route where+    Path  a   d == Path  b   d' = a == b && d == d'+    Fetch a _ d == Fetch b _ d' = a == b && d == d'+    End         == End          = True+    _           == _            = False++data Documents = Documents+    { noGroup :: [PathDoc]+    , groups  :: [(T.Text, [PathDoc])]+    }++data PathDoc = PathDoc+    { path    :: Route+    , methods :: [(HT.Method, MethodDoc)]+    }++data QueryDoc = QueryDoc+    { queryName     :: S.ByteString+    , queryStrategy :: StrategyRep+    , queryRep      :: QueryRep+    , queryDocument :: Html+    }++data MethodDoc = MethodDoc+    { queries  :: [QueryDoc]+    , document :: T.Text+    }++docToDocument :: Doc -> Maybe (Maybe T.Text, PathDoc)+docToDocument = \case+    (DocGroup g d') -> (Just  g,) <$> loop id (\md -> [("ANY", md)]) id d'+    d'              -> (Nothing,) <$> loop id (\md -> [("ANY", md)]) id d'+  where+    loop ph mh qs (DocPath        t d)  = loop (ph . Path t) mh qs d+    loop _  mh qs (DocRoot          d)  = loop (const $ Path "" End) mh qs d+    loop ph mh qs (DocFetch     t h d)  = loop (ph . Fetch t h) mh qs d+    loop ph _  qs (DocMethod      m d)  = loop ph (\md -> [(m, md)]) qs d+    loop ph mh qs (DocQuery p s q t d)  = loop ph mh (qs . (QueryDoc p s q t:)) d+    loop ph mh qs (DocGroup       _ d)  = loop ph mh qs d+    loop ph mh qs (Document   (Just t)) = Just . PathDoc (ph End) $ mh (MethodDoc (qs []) t)+    loop _  _  _  (Document   Nothing)  = Nothing++mergeMethod :: [PathDoc] -> [PathDoc]+mergeMethod [] = []+mergeMethod (pd:pds) = merge pd (filter (same pd) pds) : mergeMethod (filter (not . same pd) pds)+  where+    same = (==) `on` path+    merge pd' pds' = PathDoc (path pd') (methods pd' ++ concatMap methods pds')++docsToDocuments :: [Doc] -> Documents+docsToDocuments doc =+    let gds = mapMaybe docToDocument doc+        ngs = mergeMethod . map snd $ filter ((Nothing ==) . fst)   gds+        gs  = map upGroup . groupBy ((==) `on` fst) $ mapMaybe trav gds+    in Documents ngs gs+  where+    upGroup ((g,d):ig) = (g, mergeMethod $ d : map snd ig)+    upGroup []         = error "docsToDocuments: unknown error."++    trav (Nothing, _) = Nothing+    trav (Just a,  b) = Just (a, b)++routeToHtml :: Route -> (Html, Html)+routeToHtml = loop (1::Int) mempty []+  where+    sp = H.span "/" ! A.class_ "splitter"+    loop i r p (Path s d)          = loop i (r <> sp <> H.span (toHtml s) ! A.class_ "path") p d+    loop i r p (Fetch t Nothing d) = +        loop i (r <> sp <> H.span (toHtml $ ':' : show t) ! A.class_ "fetch") p d+    loop i r p (Fetch t (Just h) d) = +        loop (succ i) (r <> sp <> H.span (toHtml (':' : show t) <> H.sup (toHtml i)) ! A.class_ "fetch")+            (p <> [H.tr $ H.td (toHtml i) <> H.td (toHtml $ show t) <> H.td h]) d+    loop _ r p End =+        (r, if null p+            then mempty+            else H.table ! A.class_ "table table-condensed col-sm-offset-1 col-md-offset-1" $+                 H.caption "Route Parameters" <>+                 H.tr (H.th "#" <> H.th "type" <> H.th "description") <>+                 mconcat p+        )+++defaultDocumentToHtml :: Documents -> Html+defaultDocumentToHtml docs = H.docTypeHtml $ H.head headH <> H.body body+  where+    css u = H.link ! A.rel "stylesheet" ! A.href u+    headH = H.title "API document" <>+        css "//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css"++    htmlQR (Strict   r) = toHtml (show r)+    htmlQR (Nullable r) = toHtml (show r ++ "?")+    htmlQR  Check       = toHtml ("check" :: T.Text)++    query (QueryDoc p s q t) = H.tr $+        H.td (toHtml $ T.decodeUtf8 p) <> H.td (toHtml $ strategyInfo s) <> H.td (htmlQR q) <> H.td t++    queriesH []    = mempty+    queriesH qs    =+        H.table ! A.class_ "table table-condensed col-sm-offset-1 col-md-offset-1" $+        H.caption "Query Parameters" <>+        H.tr (H.th "name" <> H.th "num" <> H.th "type" <> H.th "description") <>+        mconcat (map query qs)++    method (m, MethodDoc qs d) = +        H.div ! A.class_ "col-sm-offset-1 col-md-offset-1" $+        H.h4 (toHtml $ T.decodeUtf8 m) <> +        (H.p ! A.class_ "col-sm-offset-1 col-md-offset-1") (toHtml d) <>+        queriesH qs++    pathH (PathDoc r ms) =+        let (route, rdoc) = routeToHtml r+            in H.div $ H.h3 route <> rdoc <> (H.div $ mconcat (map method ms))++    groupH (g, p) = H.div $ H.h2 (toHtml g) <> (mconcat $ map pathH p)++    doc (Documents n g) = H.div (mconcat $ map pathH n) <> mconcat (map groupH g)++    body  = H.div ! A.class_ "container" $+        H.h1 "API document" <> doc docs

@@ -8,6 +8,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}  module Data.Apiary.Param where @@ -17,65 +22,96 @@ import qualified Data.Text.Lazy.Encoding as TL import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L-import Data.Text.Encoding.Error-import Text.Read import Data.Int import Data.Word import Data.Proxy import Data.String(IsString)-+import Data.Text.Encoding.Error+import Text.Read import Network.Wai-import Network.Wai.Parse +#if __GLASGOW_HASKELL__ > 707+import qualified Data.Typeable+import Data.Typeable hiding (typeRep)+typeRep   = Data.Typeable.typeRep+#else+import Data.Typeable+typeRep _ = typeOf (undefined :: a)+#endif+typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep+{-# INLINE typeRep #-}+ jsToBool :: (IsString a, Eq a) => a -> Bool jsToBool = flip notElem jsFalse-    where-      jsFalse = ["false", "0", "-0", "", "null", "undefined", "NaN"]+  where+    jsFalse = ["false", "0", "-0", "", "null", "undefined", "NaN"]  readPathAs :: Path a => proxy a -> T.Text -> Maybe a readPathAs _ t = readPath t -class Path a where-  readPath :: T.Text -> Maybe a+data Text deriving Typeable +type Param = (S.ByteString, S.ByteString)++data File = File+    { fileParameter   :: S.ByteString+    , fileName        :: S.ByteString+    , fileContentType :: S.ByteString+    , fileContent     :: L.ByteString+    } deriving (Show, Eq, Typeable)++data QueryRep+    = Strict   TypeRep+    | Nullable TypeRep+    | Check+    deriving (Show, Eq)++class Typeable a => Path a where+    readPath :: T.Text  -> Maybe a+    pathRep  :: proxy a -> TypeRep+    pathRep = typeRep+ instance Path Char where-    readPath    s | T.null s  = Nothing-                  | otherwise = Just $ T.head s+    readPath s+        | T.null s  = Nothing+        | otherwise = Just $ T.head s  -- | 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 -instance Path Int     where readPath    = readMaybe . T.unpack-instance Path Int8    where readPath    = readMaybe . T.unpack-instance Path Int16   where readPath    = readMaybe . T.unpack-instance Path Int32   where readPath    = readMaybe . T.unpack-instance Path Int64   where readPath    = readMaybe . T.unpack-instance Path Integer where readPath    = readMaybe . T.unpack+instance Path Int     where readPath = readMaybe . T.unpack+instance Path Int8    where readPath = readMaybe . T.unpack+instance Path Int16   where readPath = readMaybe . T.unpack+instance Path Int32   where readPath = readMaybe . T.unpack+instance Path Int64   where readPath = readMaybe . T.unpack+instance Path Integer where readPath = readMaybe . T.unpack -instance Path Word   where readPath    = readMaybe . T.unpack-instance Path Word8  where readPath    = readMaybe . T.unpack-instance Path Word16 where readPath    = readMaybe . T.unpack-instance Path Word32 where readPath    = readMaybe . T.unpack-instance Path Word64 where readPath    = readMaybe . T.unpack+instance Path Word    where readPath = readMaybe . T.unpack+instance Path Word8   where readPath = readMaybe . T.unpack+instance Path Word16  where readPath = readMaybe . T.unpack+instance Path Word32  where readPath = readMaybe . T.unpack+instance Path Word64  where readPath = readMaybe . T.unpack -instance Path Double  where readPath    = readMaybe . T.unpack-instance Path Float   where readPath    = readMaybe . T.unpack+instance Path Double  where readPath = readMaybe . T.unpack+instance Path Float   where readPath = readMaybe . T.unpack -instance Path  T.Text      where readPath    = Just-instance Path TL.Text      where readPath    = Just . TL.fromStrict-instance Path S.ByteString where readPath    = Just . T.encodeUtf8-instance Path L.ByteString where readPath    = Just . TL.encodeUtf8 . TL.fromStrict-instance Path String       where readPath    = Just . T.unpack+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)+instance Path S.ByteString where readPath = Just . T.encodeUtf8;  pathRep _ = typeRep (Proxy :: Proxy Text)+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 Query a where+class Typeable a => Query a where     readQuery :: Maybe S.ByteString -> Maybe a+    queryRep  :: proxy a            -> QueryRep+    queryRep = Strict . typeRep  -- | 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  instance Query Int     where readQuery = maybe Nothing (readMaybe . S.unpack) instance Query Int8    where readQuery = maybe Nothing (readMaybe . S.unpack)@@ -84,29 +120,45 @@ instance Query Int64   where readQuery = maybe Nothing (readMaybe . S.unpack) instance Query Integer where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Word   where readQuery = maybe Nothing (readMaybe . S.unpack)-instance Query Word8  where readQuery = maybe Nothing (readMaybe . S.unpack)-instance Query Word16 where readQuery = maybe Nothing (readMaybe . S.unpack)-instance Query Word32 where readQuery = maybe Nothing (readMaybe . S.unpack)-instance Query Word64 where readQuery = maybe Nothing (readMaybe . S.unpack)+instance Query Word    where readQuery = maybe Nothing (readMaybe . S.unpack)+instance Query Word8   where readQuery = maybe Nothing (readMaybe . S.unpack)+instance Query Word16  where readQuery = maybe Nothing (readMaybe . S.unpack)+instance Query Word32  where readQuery = maybe Nothing (readMaybe . S.unpack)+instance Query Word64  where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Double where readQuery = maybe Nothing (readMaybe . S.unpack)-instance Query Float  where readQuery = maybe Nothing (readMaybe . S.unpack)+instance Query Double  where readQuery = maybe Nothing (readMaybe . S.unpack)+instance Query Float   where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query T.Text       where readQuery = fmap $ T.decodeUtf8With lenientDecode-instance Query TL.Text      where readQuery = fmap (TL.decodeUtf8With lenientDecode . L.fromStrict)-instance Query S.ByteString where readQuery = id-instance Query L.ByteString where readQuery = fmap L.fromStrict-instance Query String       where readQuery = fmap S.unpack+instance Query T.Text  where+    readQuery  = fmap $ T.decodeUtf8With lenientDecode+    queryRep _ = Strict (typeRep (Proxy :: Proxy Text)) +instance Query TL.Text where+    readQuery  = fmap (TL.decodeUtf8With lenientDecode . L.fromStrict)+    queryRep _ = Strict (typeRep (Proxy :: Proxy Text))++instance Query S.ByteString where +    readQuery  = id+    queryRep _ = Strict (typeRep (Proxy :: Proxy Text))++instance Query L.ByteString where +    readQuery  = fmap L.fromStrict+    queryRep _ = Strict (typeRep (Proxy :: Proxy Text))++instance Query String       where+    readQuery  = fmap S.unpack+    queryRep _ = Strict (typeRep (Proxy :: Proxy Text))+ -- | allow no parameter. but check parameter type. instance Query a => Query (Maybe a) where     readQuery (Just a) = Just `fmap` readQuery (Just a)     readQuery Nothing  = Just Nothing+    queryRep  _        = Nullable $ typeRep (Proxy :: Proxy a)  -- | always success. for exists check. instance Query () where     readQuery _ = Just ()+    queryRep _ = Check  pBool :: Proxy Bool pBool = Proxy@@ -157,15 +209,18 @@ pMaybe :: proxy a -> Proxy (Maybe a) pMaybe _ = Proxy -pFile :: Proxy (File L.ByteString)+pFile :: Proxy File pFile = Proxy  class ReqParam a where-  reqParams :: Proxy a -> Request -> [Param] -> [File L.ByteString] -> [(S.ByteString, Maybe a)]+    reqParams   :: proxy a -> Request -> [Param] -> [File] -> [(S.ByteString, Maybe a)]+    reqParamRep :: proxy a -> QueryRep -instance ReqParam (FileInfo L.ByteString) where-    reqParams _ _ _ f = map (\(k,v) -> (k, Just v)) f+instance ReqParam File where+    reqParams _ _ _ = map (\f -> (fileParameter f, Just f))+    reqParamRep   _ = Strict $ typeRep pFile  instance Query a => ReqParam a where     reqParams _ r p _ = map (\(k,v) -> (k, readQuery v)) (queryString r) ++         map (\(k,v) -> (k, readQuery $ Just v)) p+    reqParamRep = queryRep

@@ -1,6 +1,5 @@ module Web.Apiary -    (-      module Control.Monad.Apiary+    ( module Control.Monad.Apiary     , module Control.Monad.Apiary.Action     , module Control.Monad.Apiary.Filter     , module Data.Apiary.Param

@@ -4,7 +4,6 @@  import Control.Monad.Apiary import Control.Monad.Apiary.Action-import Network.HTTP.Types.Status import Language.Haskell.TH import Language.Haskell.TH.Quote import qualified Data.Text as T