diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -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 diff --git a/src/Control/Monad/Apiary.hs b/src/Control/Monad/Apiary.hs --- a/src/Control/Monad/Apiary.hs +++ b/src/Control/Monad/Apiary.hs @@ -5,6 +5,9 @@ , runApiaryTWith , runApiaryWith , runApiary + , getApiaryTWith + , getApiaryWith + , getApiary , ApiaryConfig(..) -- * execute action , action diff --git a/src/Control/Monad/Apiary/Action.hs b/src/Control/Monad/Apiary/Action.hs --- a/src/Control/Monad/Apiary/Action.hs +++ b/src/Control/Monad/Apiary/Action.hs @@ -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 diff --git a/src/Control/Monad/Apiary/Action/Internal.hs b/src/Control/Monad/Apiary/Action/Internal.hs --- a/src/Control/Monad/Apiary/Action/Internal.hs +++ b/src/Control/Monad/Apiary/Action/Internal.hs @@ -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 diff --git a/src/Control/Monad/Apiary/Filter.hs b/src/Control/Monad/Apiary/Filter.hs --- a/src/Control/Monad/Apiary/Filter.hs +++ b/src/Control/Monad/Apiary/Filter.hs @@ -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 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 diff --git a/src/Control/Monad/Apiary/Internal.hs b/src/Control/Monad/Apiary/Internal.hs --- a/src/Control/Monad/Apiary/Internal.hs +++ b/src/Control/Monad/Apiary/Internal.hs @@ -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) diff --git a/src/Data/Apiary/Param.hs b/src/Data/Apiary/Param.hs --- a/src/Data/Apiary/Param.hs +++ b/src/Data/Apiary/Param.hs @@ -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) diff --git a/src/Web/Apiary.hs b/src/Web/Apiary.hs --- a/src/Web/Apiary.hs +++ b/src/Web/Apiary.hs @@ -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 ) diff --git a/tests/Application.hs b/tests/Application.hs --- a/tests/Application.hs +++ b/tests/Application.hs @@ -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 ]