apiary 1.4.5 → 2.0.0

raw patch · 10 files changed

+340/−70 lines, 10 filesdep +aesondep +directorydep +resourcetdep ~wai-extranew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, directory, resourcet

Dependency ranges changed: wai-extra

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• apiary.cabal +11/−7
• src/Control/Monad/Apiary.hs +3/−0
• src/Control/Monad/Apiary/Action.hs +3/−2
• src/Control/Monad/Apiary/Action/Internal.hs +118/−41
• src/Control/Monad/Apiary/Filter.hs +15/−4
• src/Control/Monad/Apiary/Internal.hs +38/−3
• src/Data/Apiary/Param.hs +10/−8
• src/Web/Apiary.hs +7/−2
• tests/Application.hs +128/−3

@@ -1,3 +1,10 @@+# 2.0.0+* add methods to get application from Apiary monad stack.+* add Control.Monad.Apiary.Action.application to mount a wai application at certain route.+* rewrite getReqBody to allow file upload with temp file backend, check out ApiaryConfig and Data.Param.File.+* guard against large request body.+* add Control.Monad.Filter.jsonReqBody to do type level route based on request body's JSON type.+ # 1.4.5 * fix: MonadPlus lows of ApiaryT Monad 

@@ -1,5 +1,5 @@ name:                apiary-version:             1.4.5+version:             2.0.0 synopsis:            Simple and type safe web framework that generate web API documentation. description:   Simple and type safe web framework that can be automatically generate API documentation.@@ -95,8 +95,9 @@                      , mtl                  >=2.1   && <2.3                      , monad-control        >=0.3   && <1.1                      , exceptions           >=0.6   && <0.9+                     , resourcet            >=0.4.6 && <1.2 -                     , http-types           >=0.8   && <0.9+                     , http-types           >=0.8   && <0.10                      , mime-types           >=0.1   && <0.2                       , text                 >=1.1   && <1.3@@ -107,6 +108,7 @@                      , blaze-markup         >=0.6   && <0.8                      , case-insensitive     >=1.1   && <1.3                      , vault                >=0.3   && <0.4+                     , aeson                >=0.8   && <0.12                       , data-default-class   >=0.0   && <0.1                      , unordered-containers >=0.2   && <0.3@@ -116,8 +118,8 @@                      , unix-compat          >=0.4   && <0.5                      , http-date            >=0.0   && <0.1 -                     , wai                  >=3.0   && <3.1-                     , wai-extra            >=3.0   && <3.1+                     , wai                  >=3.0   && <3.3+                     , wai-extra            >=3.0.15 && <3.1                      , stringsearch         >=0.3   && <0.4                      , web-routing          >=0.6   && <0.7                      , types-compat         >=0.1   && <0.2@@ -134,15 +136,17 @@   type:                exitcode-stdio-1.0   build-depends:       base                      >=4.6   && <4.9                      , mtl                       >=2.1   && <2.3-                     , tasty                     >=0.10  && <0.11+                     , tasty                     >=0.10  && <0.12                      , tasty-hunit               >=0.9   && <0.10                      , tasty-quickcheck          >=0.8   && <0.9                      , apiary                      , bytestring           >=0.10  && <0.11-                     , http-types           >=0.8   && <0.9+                     , http-types           >=0.8   && <0.10                      , HUnit                >=1.2   && <1.4-                     , wai                  >=3.0   && <3.1+                     , wai                  >=3.0   && <3.3                      , wai-extra            >=3.0   && <3.1+                     , directory+                     , aeson                >=0.8   && <0.12    hs-source-dirs:      tests   ghc-options:         -Wall -fno-warn-missing-signatures

@@ -5,6 +5,9 @@     , runApiaryTWith     , runApiaryWith     , runApiary+    , getApiaryTWith+    , getApiaryWith+    , getApiary     , ApiaryConfig(..)     -- * execute action     , action

@@ -1,7 +1,8 @@-module Control.Monad.Apiary.Action +module Control.Monad.Apiary.Action     ( ActionT     , hoistActionT     -- * stop action+    , application     , stop      -- * getter@@ -46,7 +47,7 @@     , getParams     , getQueryParams -    , RequestBody(..), getReqBody+    , ActionReqBody(..), getReqBody     , getReqBodyParams     , getReqBodyFiles     -- ** setter

@@ -18,6 +18,7 @@ module Control.Monad.Apiary.Action.Internal     ( ActionT +    , application     , stop      , param@@ -57,7 +58,8 @@     , getQueryParams     , getReqBodyParams     , getReqBodyFiles-    , RequestBody(..)+    , getReqBodyJSON+    , ActionReqBody(..)     , getReqBody      , devFile@@ -78,7 +80,7 @@     , getConfig     , getState     , modifyState-    , getRequestBody+    , getReqBodyInternal     , execActionT     , applyDict @@ -109,12 +111,15 @@     (MonadTransControl(..), MonadBaseControl(..)     , ComposeSt     , defaultLiftBaseWith, defaultRestoreM)+import Control.Exception (try, onException)+import Control.Monad.Trans.Resource (createInternalState, closeInternalState)  import Network.Mime(defaultMimeLookup) import Network.HTTP.Date(parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate) import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai import qualified Network.Wai.Parse as P+import Network.Wai.Request (requestSizeCheck, RequestSizeException(..))  import qualified Network.Routing.Dict as Dict import Data.Apiary.Param(Param, File(..))@@ -133,6 +138,9 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Vault.Lazy as V+import Data.Word (Word64)+import Data.Aeson (FromJSON)+import qualified Data.Aeson as JSON  data ApiaryConfig = ApiaryConfig     { -- | call when no handler matched.@@ -144,6 +152,14 @@     , defaultContentType  :: S.ByteString     , failStatus          :: HTTP.Status     , failHeaders         :: HTTP.ResponseHeaders+      -- | maximum request size, default to 5MB. since 2.0.0.+    , maxRequestSize      :: Word64+      -- | where to store upload file. since 2.0.0.+      --+      -- default to 'Nothing', which saves file content in memory.+      -- NOTE. once you set this value to some path,+      -- it's your responsibility to clean uploaded files. eg. move or remove it.+    , uploadFilePath      :: Maybe FilePath       -- | used by 'Control.Monad.Apiary.Filter.root' filter.     , rootPattern         :: [T.Text]     , mimeType            :: FilePath -> S.ByteString@@ -160,7 +176,7 @@ defaultNotFound _ f = f      $ Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"  instance Default ApiaryConfig where-    def = ApiaryConfig +    def = ApiaryConfig         { notFound            = defaultNotFound         , defaultStatus       = HTTP.ok200         , defaultHeaders      = []@@ -168,6 +184,8 @@         , failStatus          = HTTP.internalServerError500         , failHeaders         = []         , rootPattern         = ["index.html", "index.htm"]+        , maxRequestSize      = 5242880+        , uploadFilePath      = Nothing         , mimeType            = defaultMimeLookup . T.pack         } @@ -197,13 +215,11 @@  -------------------------------------------------------------------------------- -data RequestBody-    = Unknown S.ByteString -- ^ raw body-    | UrlEncoded [Param] [File]-    | Multipart-        {-#UNPACK#-}!S.ByteString-        [Param]-        [File] -- ^ boundary params files+data ActionReqBody+    = Unknown L.ByteString -- ^ raw body+    | UrlEncoded [Param]   -- ^ url-encoded params+    | Multipart [Param] [File] -- ^ boundary params files+  deriving (Show, Eq)  data ActionState = ActionState     { actionResponse    :: ResponseBody@@ -211,7 +227,7 @@     , actionHeaders     :: HTTP.ResponseHeaders     , actionVault       :: V.Vault     , actionContentType :: S.ByteString-    , actionReqBody     :: Maybe RequestBody+    , actionReqBody     :: Maybe ActionReqBody     }  initialState :: ApiaryConfig -> ActionState@@ -256,12 +272,13 @@     , actionExts      :: Extensions exts     } -data Action a +data Action a     = Continue ActionState a-    | Pass (Maybe RequestBody)+    | Pass (Maybe ActionReqBody)     | Stop Wai.Response+    | App Wai.Application -newtype ActionT exts prms m a = ActionT { unActionT :: forall b. +newtype ActionT exts prms m a = ActionT { unActionT :: forall b.     Dict.Dict prms     -> ActionEnv exts     -> ActionState@@ -276,15 +293,22 @@     return (Continue st' a) {-# INLINE runActionT #-} -actionT :: Monad m +actionT :: Monad m         => (Dict.Dict prms -> ActionEnv exts -> ActionState -> m (Action a))         -> ActionT exts prms m a actionT f = ActionT $ \dict env !st cont -> f dict env st >>= \case     Pass b          -> return $ Pass b     Stop s          -> return $ Stop s     Continue !st' a -> cont a st'+    App a           -> return $ App a {-# INLINE actionT #-} +-- | stop and proxy current request to a 'Wai.Application', since 2.0.0.+application :: Monad m+        => Wai.Application+        -> ActionT exts prms m a+application app = ActionT $ \_ _ _ _ -> return $ App app+ -- | n must be Monad, so cant be MFunctor. hoistActionT :: (Monad m, Monad n)              => (forall b. m b -> n b) -> ActionT exts prms m a -> ActionT exts prms n a@@ -296,11 +320,12 @@ {-# INLINE applyDict #-}  execActionT :: ApiaryConfig -> Extensions exts -> Documents -> ActionT exts '[] IO () -> Wai.Application-execActionT config exts doc m request send = +execActionT config exts doc m request send =     runActionT m Dict.emptyDict (ActionEnv config request doc exts) (initialState config) >>= \case         Pass _       -> notFound config request send         Stop s       -> send s         Continue r _ -> send $ toResponse r+        App a        -> a request send  -------------------------------------------------------------------------------- @@ -360,6 +385,7 @@         Continue !st a -> return $ Continue st a         Stop stp       -> return $ Stop stp         Pass b         -> unActionT n dict e s { actionReqBody = b } cont+        App a          -> return $ App a     {-# INLINE mzero #-}     {-# INLINE mplus #-} @@ -374,7 +400,7 @@     restoreT m = actionT $ \_ _ _ -> m #else     newtype StT (ActionT exts prms) a = StActionT { unStActionT :: Action a }-    liftWith f = actionT $ \prms e !s -> +    liftWith f = actionT $ \prms e !s ->         liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t prms e s)     restoreT m = actionT $ \_ _ _ -> liftM unStActionT m #endif@@ -444,51 +470,102 @@     , quoteDec  = error "params QQ is defined only exp."     } +-- | only get parameters in query string.+getQueryParams :: Monad m => ActionT exts prms m HTTP.Query+getQueryParams = Wai.queryString <$> getRequest+ getDocuments :: Monad m => ActionT exts prms m Documents getDocuments = liftM actionDocuments getEnv --- | parse request body and return it. since 1.2.2.-getReqBody :: MonadIO m => ActionT exts prms m RequestBody+-- | parse request body into 'ActionReqBody' and return it. since 1.2.2.+getReqBody :: MonadIO m => ActionT exts prms m ActionReqBody getReqBody = ActionT $ \_ e s c -> case actionReqBody s of     Just  b -> c b s     Nothing -> do         let req  = actionRequest e-            body = Wai.requestBody req-        b <- liftIO $ case P.getRequestBodyType req of-            Nothing                  -> Unknown `liftM` body-            Just typ@P.UrlEncoded    -> sink UrlEncoded typ body-            Just typ@(P.Multipart b) -> sink (Multipart b) typ body-        c b s { actionReqBody = Just b }+            config = actionConfig e+            rbody = Wai.requestBody =<< requestSizeCheck (maxRequestSize config) req++        b <- liftIO $ try (+            case P.getRequestBodyType req of+                Nothing                  -> sinkRaw rbody+                Just typ@P.UrlEncoded    -> sinkUrlEncoded typ rbody+                Just typ@(P.Multipart _) ->+                    case uploadFilePath config of+                        Nothing -> sinkMultipartLBS typ rbody+                        Just p  -> sinkMultipartToDisk p typ rbody+            )+        case b of+            Left (RequestSizeException limit) ->+                return $ Stop $ Wai.responseLBS HTTP.status413 [] $ B.toLazyByteString $+                    "Request body is too large(limit is "+                        `mappend` B.fromString (show limit) `mappend` " bytes)"+            Left _   ->+                return $ Stop $ Wai.responseLBS HTTP.status400 [] $ "Bad Request"++            Right b' ->+                c b' s { actionReqBody = Just b' }   where-    sink con typ body = do-        (p, f) <- P.sinkRequestBody P.lbsBackEnd typ body-        return $ con p (map convFile f)+    sinkRaw rbody = do+        let loop front = do+                bs <- rbody+                if S.null bs+                    then return $ L.fromChunks $ front []+                    else loop $ front . (bs:)+        Unknown `liftM` loop id -    convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent+    sinkUrlEncoded typ rbody = do+        (p, _) <- P.sinkRequestBody P.lbsBackEnd typ rbody+        return (UrlEncoded p) -getQueryParams :: Monad m => ActionT exts prms m HTTP.Query-getQueryParams = Wai.queryString <$> getRequest+    sinkMultipartLBS typ rbody = do+        (p, f) <- P.sinkRequestBody P.lbsBackEnd typ rbody+        let f' = map (\ (pn, P.FileInfo{..})+                    -> File pn fileName fileContentType (Left fileContent)+                ) f+        return (Multipart p f') -getRequestBody :: MonadIO m => ActionT exts prms m ([Param], [File])-getRequestBody = getReqBody >>= return . \case+    sinkMultipartToDisk path typ rbody = do+        internalState <- createInternalState+        (p, f) <-+            P.sinkRequestBody+                (P.tempFileBackEndOpts (return path) "apiaryUpload" internalState)+                typ+                rbody+            `onException` closeInternalState internalState+        let f' = map (\ (pn, P.FileInfo{..})+                    -> File pn fileName fileContentType (Right fileContent)+                ) f+        return (Multipart p f')++getReqBodyInternal :: MonadIO m => ActionT exts prms m ([Param], [File])+getReqBodyInternal = getReqBody >>= return . \case     Unknown _       -> ([], [])-    UrlEncoded  p f -> (p, f)-    Multipart _ p f -> (p, f)+    UrlEncoded  p   -> (p, [])+    Multipart   p f -> (p, f)  -- | parse request body and return params. since 1.0.0. getReqBodyParams :: MonadIO m => ActionT exts prms m [Param] getReqBodyParams = getReqBody >>= return . \case     Unknown _       -> []-    UrlEncoded  p _ -> p-    Multipart _ p _ -> p+    UrlEncoded  p   -> p+    Multipart   p _ -> p  -- | parse request body and return files. since 0.9.0.0. getReqBodyFiles :: MonadIO m => ActionT exts prms m [File] getReqBodyFiles = getReqBody >>= return . \case-    Unknown _       -> []-    UrlEncoded  _ f -> f-    Multipart _ _ f -> f+    Multipart   _ f -> f+    _               -> [] +-- | parse request body and try parse it as JSON.+--+-- it's recommended to use 'Control.Monad.Apiary.Filter.jsonReqBody' filter+-- to leverage type level routing instead of 'getReqBodyJSON'. since 2.0.0.+getReqBodyJSON :: (MonadIO m, FromJSON a) => ActionT exts prms m (Maybe a)+getReqBodyJSON = getReqBody >>= return . \case+    Unknown lbs     -> JSON.decode' lbs+    _               -> Nothing+ -- | get all request headers. since 0.6.0.0. getHeaders :: Monad m => ActionT exts prms m HTTP.RequestHeaders getHeaders = Wai.requestHeaders `liftM` getRequest@@ -591,7 +668,7 @@ -- -- 303 See Other (HTTP/1.1)  or -- 302 Moved Temporarily (Other)--- +-- -- since 0.6.2.0. redirect :: Monad m => S.ByteString -> ActionT exts prms m () redirect to = do

@@ -24,6 +24,7 @@     -- * header matcher     , eqHeader     , header+    , jsonReqBody     , accept      -- * other@@ -47,8 +48,8 @@ import Control.Monad.Trans(MonadIO)  import Control.Monad.Apiary.Action.Internal-    ( getQueryParams, getRequestBody-    , getRequest, ContentType, contentType+    ( getQueryParams, getReqBodyInternal+    , getRequest, getReqBodyJSON, ContentType, contentType     , getConfig, ApiaryConfig(..)     ) @@ -78,6 +79,7 @@     , pFirst, pOne, pOption, pOptional, pMany, pSome     ) import Data.Apiary.Method(Method)+import Data.Aeson (FromJSON)  -- | filter by HTTP method. since 0.1.0.0. --@@ -145,7 +147,7 @@       => query k -> strategy v -> Filter exts actM m prms (SNext strategy k v prms) query k w = focus doc Nothing $ R.raw "query" $ \d t -> do     qs      <- getQueryParams-    (ps,fs) <- getRequestBody+    (ps,fs) <- getReqBodyInternal     let as = map snd . filter ((SC.pack (symbolVal k) ==) . fst) $ reqParams (Proxy :: Proxy v) qs ps fs     case strategy w k as d of         Nothing -> mzero@@ -218,7 +220,7 @@             => proxy k -> Filter exts actM m prms (k ':= Bool ': prms) switchQuery k = focus doc Nothing $ R.raw "switch" $ \d t -> do     qs      <- getQueryParams-    (ps,fs) <- getRequestBody+    (ps,fs) <- getReqBodyInternal     let n = maybe False id . fmap (maybe True id) . lookup (SC.pack $ symbolVal k) $ reqParams (Proxy :: Proxy Bool) qs ps fs     return (Dict.add k n d, t)   where@@ -243,6 +245,15 @@     if v == v' then return (d,t) else mzero   where     doc = DocPrecondition $ "header: " <> toHtml (symbolVal k) <> " = " <> toHtml (show v)++-- | filter by JSON typed body. since 2.0.0.+jsonReqBody :: (KnownSymbol k, MonadIO actM, k </ prms, FromJSON a)+       => proxy k -> Filter exts actM m prms (k ':= a ': prms)+jsonReqBody k = focus doc Nothing $ R.raw "json body" $ \d t -> do+    n <- maybe mzero return =<< getReqBodyJSON+    return (Dict.add k n d, t)+  where+    doc = DocPrecondition $ "json body: " <> toHtml (symbolVal k)  -- | require Accept header and set response Content-Type. since 0.16.0. accept :: Monad actM => ContentType -> Filter' exts actM m

@@ -14,6 +14,9 @@     , runApiaryTWith     , runApiaryWith     , runApiary+    , getApiaryTWith+    , getApiaryWith+    , getApiary     , ApiaryConfig(..)      , action@@ -96,7 +99,7 @@ newtype ApiaryT exts prms actM m a = ApiaryT { unApiaryT :: forall b.     ApiaryEnv exts prms actM     -> (a -> ApiaryWriter exts actM -> m b)-    -> m b +    -> m b     }  apiaryT :: Monad m@@ -141,6 +144,35 @@           -> m a runApiary run = runApiaryWith run noExtension +-- | get 'Application' from Apiary monad. since 2.0.0.+getApiaryTWith :: (Monad actM, Monad m)+               => (forall b. actM b -> IO b)+               -> Initializer m '[] exts+               -> ApiaryConfig+               -> ApiaryT exts '[] actM m ()+               -> m Wai.Application+getApiaryTWith runAct (Initializer ir) conf m = ir NoExtension $ \exts -> do+    wtr <- unApiaryT m (initialEnv conf exts) (\_ w -> return w)+    let doc = docsToDocuments $ writerDoc wtr []+        rtr = writerRouter wtr R.empty+        mw  = allMiddleware exts . writerMw wtr+        mw' = allMiddleware' exts+        app = mw $ execActionT conf exts doc (mw' $ hoistActionT runAct $ routerToAction rtr)+    return $! app++getApiaryWith :: Monad m+              => Initializer m '[] exts+              -> ApiaryConfig+              -> ApiaryT exts '[] IO m ()+              -> m Wai.Application+getApiaryWith = getApiaryTWith id++getApiary :: Monad m+          => ApiaryConfig+          -> ApiaryT '[] '[] IO m ()+          -> m Wai.Application+getApiary = getApiaryWith noExtension+ --------------------------------------------------------------------------------  instance Functor (ApiaryT exts prms actM m) where@@ -159,7 +191,7 @@     return x = ApiaryT $ \_ cont -> cont x mempty     m >>= k = ApiaryT $ \env cont ->         unApiaryT    m  env $ \a hdr  ->-        unApiaryT (k a) env $ \b hdr' -> +        unApiaryT (k a) env $ \b hdr' ->         let hdr'' = hdr `mappend` hdr'         in hdr'' `seq` cont b hdr'' @@ -180,7 +212,7 @@ #else     newtype StT (ApiaryT exts prms actM) a = StTApiary { unStTApiary :: (a, ApiaryWriter exts actM) }     liftWith f = apiaryT $ \env ->-        liftM (\a -> (a, mempty)) +        liftM (\a -> (a, mempty))         (f $ \t -> liftM StTApiary $ unApiaryT t env (\a w -> return (a,w)))     restoreT m = apiaryT $ \_ -> liftM unStTApiary m #endif@@ -243,6 +275,9 @@         id  -- | add middleware.+--+-- please note that, this method just provide a shortcut to stack middleware.+-- middlewares are added to whole Apiary application rather than specific route. middleware :: Monad actM => Wai.Middleware -> ApiaryT exts prms actM m () middleware mw = addRoute (ApiaryWriter id id mw) 

@@ -97,12 +97,14 @@  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 File+    = File {+          fileParameter   :: S.ByteString+        , fileName        :: S.ByteString+        , fileContentType :: S.ByteString+        , fileContent     :: Either L.ByteString FilePath+        }+    deriving (Show, Eq, Typeable)  data QueryRep     = Strict   TypeRep -- ^ require value@@ -223,11 +225,11 @@     readQuery  = fmap (TL.decodeUtf8With lenientDecode . L.fromStrict)     qTypeRep _ = typeRep (Proxy :: Proxy Text) -instance Query S.ByteString where +instance Query S.ByteString where     readQuery  = id     qTypeRep _ = typeRep (Proxy :: Proxy Text) -instance Query L.ByteString where +instance Query L.ByteString where     readQuery  = fmap L.fromStrict     qTypeRep _ = typeRep (Proxy :: Proxy Text) 

@@ -1,6 +1,6 @@ {-# LANGUAGE ExplicitNamespaces #-} -module Web.Apiary +module Web.Apiary     ( module Control.Monad.Apiary     , module Control.Monad.Apiary.Action     , module Control.Monad.Apiary.Filter@@ -28,12 +28,15 @@     -- | Html     , module Text.Blaze.Html     ) where- + import Control.Monad.Apiary     ( ApiaryT     , runApiaryTWith     , runApiaryWith     , runApiary+    , getApiaryTWith+    , getApiaryWith+    , getApiary     , ApiaryConfig(..)     , action     , middleware@@ -45,6 +48,7 @@  import Control.Monad.Apiary.Action     ( ActionT+    , application     , stop     , param     , params@@ -78,6 +82,7 @@     , switchQuery     , eqHeader     , header+    , jsonReqBody     , accept     , ssl     )

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}  {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -19,12 +20,16 @@ import qualified Network.Wai.Test as WT import qualified Network.Wai as Wai import qualified Network.HTTP.Types as HTTP+import System.Directory (removeFile)  import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S+import Data.Word (Word64)+import qualified Data.Aeson as JSON+import qualified Data.Aeson.TH as JSON  testReq :: String -> (Request -> IO ()) -> TestTree-testReq str f = +testReq str f =     let (meth, other) = break (== ' ') str         (p,  version) = break (== ' ') (tail other)     in testCase str $ f (WT.setPath (setVersion version $ (WT.defaultRequest { Wai.requestMethod = S.pack meth })) (S.pack p))@@ -88,7 +93,7 @@     method POST  . action $ contentType "text/plain" >> bytes "POST"  methodFilterTest :: TestTree-methodFilterTest = testGroup "methodFilter" $ map ($methodFilterApp)+methodFilterTest = testGroup "methodFilter" $ map ($ methodFilterApp)     [ testReq "GET /"    . assertPlain200 "GET"     , testReq "POST /"   . assertPlain200 "POST"     , testReq "GET /foo" . assert404@@ -330,7 +335,7 @@ 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 "DELETE /"        $ assertPlain200 "DELETE ANY" multipleFilter1App     , testReq "PUT /"           $ assert404 multipleFilter1App     ] @@ -360,6 +365,123 @@  -------------------------------------------------------------------------------- +limit :: Word64+limit = 1024++largeReq :: WT.SRequest+largeReq = WT.SRequest+    Wai.defaultRequest+        { Wai.requestBodyLength = Wai.KnownLength (limit + 1)+        , Wai.requestMethod = HTTP.methodPut+        }+    "some request body"++largeReq' :: WT.SRequest+largeReq' = WT.SRequest+    Wai.defaultRequest+        { Wai.requestBodyLength = Wai.ChunkedBody+        , Wai.requestMethod = HTTP.methodPost+        }+    (L.replicate (fromIntegral (limit + 1)) 'a')++assertLargeReq413 :: Application -> WT.SRequest -> IO ()+assertLargeReq413 app req = flip WT.runSession app $ do+    respond <- WT.srequest req+    WT.assertStatus 413 respond++tooLargeReqTestApp :: Application+tooLargeReqTestApp = runIdentity . runApiary return (def {maxRequestSize = limit}) $ do+    root $ do+        method PUT  . action $ do+            b <- getReqBody+            b `seq` bytes "Test"+        method POST . action $ do+            b <- getReqBody+            b `seq` bytes "Test"++tooLargeReqTest :: TestTree+tooLargeReqTest = testGroup "large request body"+    [ testCase "Large request" $ assertLargeReq413 tooLargeReqTestApp largeReq+    , testCase "Large request" $ assertLargeReq413 tooLargeReqTestApp largeReq'+    ]++--------------------------------------------------------------------------------++dalvikRequest :: IO WT.SRequest+dalvikRequest = do+    bs <- L.readFile "./tests/dalvik-request"+    return $ WT.SRequest+        Wai.defaultRequest+            {+              Wai.requestBodyLength = Wai.ChunkedBody+            , Wai.requestMethod = HTTP.methodPost+            , Wai.requestHeaders = [("Content-Type", "multipart/form-data; boundary=*****")]+            }+        bs++multiPartTestApp :: Application+multiPartTestApp = runIdentity . runApiary return def $ do+    root $ do+        method POST . action $ do+            p <- getReqBodyParams+            f <- getReqBodyFiles+            guard (not . null $ p)+            guard (not . null $ f)+            case fileContent (head f) of+                Left lbs -> bytes "lbs file"++multiPartTestApp' :: Application+multiPartTestApp' = runIdentity . runApiary return (def {uploadFilePath = Just "./"}) $ do+    root $ do+        method POST . action $ do+            p <- getReqBodyParams+            f <- getReqBodyFiles+            guard (not . null $ p)+            guard (not . null $ f)+            case fileContent (head f) of+                Right path -> do+                    liftIO $ removeFile path+                    bytes "disk file"++multiPartTest :: TestTree+multiPartTest = testGroup "multipart request body"+    [ testCase "multipart test" $ assertSRequest 200 Nothing "lbs file" multiPartTestApp =<< dalvikRequest+    , testCase "multipart test" $ assertSRequest 200 Nothing "disk file" multiPartTestApp' =<< dalvikRequest+    ]++--------------------------------------------------------------------------------++data Foo = Foo {foo :: Int} deriving Show++$(JSON.deriveJSON JSON.defaultOptions ''Foo)++jsonRequest :: WT.SRequest+jsonRequest = WT.SRequest+        Wai.defaultRequest { Wai.requestMethod = HTTP.methodPost }+        "{\"foo\": 123}"++jsonReqTestApp :: Application+jsonReqTestApp = runIdentity . runApiary return (def {uploadFilePath = Just "./"}) $ do+    root $ do+        method POST . (jsonReqBody [key|foo|]) . action $ do+            f <- param [key|foo|]+            showing $ foo f++jsonReqTestApp' :: Application+jsonReqTestApp' = runIdentity . runApiary return (def {uploadFilePath = Just "./"}) $ do+    root $ do+        method POST . (jsonReqBody [key|foo|]) . action $ do+            f <- param [key|foo|]+            showing $ (f :: Int)++jsonReqBodyTest :: TestTree+jsonReqBodyTest = testGroup "json request body filter"+    [ testCase "json request body test" $ assertSRequest 200 Nothing "123" jsonReqTestApp jsonRequest+    , testCase "json request body test" $ assertSRequest 404 (Just "text/plain") "404 Page Notfound.\n" jsonReqTestApp' jsonRequest+    ]++--------------------------------------------------------------------------------+ test :: TestTree test = testGroup "Application"     [ helloWorldAllTest@@ -373,5 +495,8 @@     , acceptTest     , multipleFilter1Test     , issue17Test+    , tooLargeReqTest+    , multiPartTest+    , jsonReqBodyTest     ]