eeva
/
servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Write tests for Optional ReqBody' and fix some cases

This commit is contained in:
Viacheslav Lotsmanov 2020-10-04 05:12:32 +03:00
parent a6be2ee728
commit a2c0a55535
No known key found for this signature in database
GPG Key ID: D276FF7467007335
2 changed files with 42 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
servant-server/src/Servant/Server/Internal.hs
View File

@ -49,8 +49,6 @@ import qualified Data.ByteString.Lazy as BL
import Data.Constraint (Constraint, Dict(..))
import Data.Either
(partitionEithers)
import Data.Function
((&))
import Data.Maybe
(fromMaybe, isNothing, mapMaybe, maybeToList)
import Data.String
@ -681,9 +679,7 @@ instance ( AllCTUnrender list a, HasServer api context
Just f -> return f
-- Body check, we get a body parsing functions as the first argument.
bodyCheck f = withRequest $ \ request -> do
mrqbody <- f <$> liftIO (lazyRequestBody request)
bodyCheck f = withRequest $ \ request ->
let
hasReqBody =
case requestBodyLength request of
@ -692,13 +688,15 @@ instance ( AllCTUnrender list a, HasServer api context
serverErr :: String -> ServerError
serverErr = formatError rep request . cs
mrqbody & case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods), hasReqBody) of
(STrue, STrue, _) -> return . bimap cs id
(STrue, SFalse, _) -> either (delayedFailFatal . serverErr) return
(SFalse, _, False) -> return . const Nothing
(SFalse, STrue, True) -> return . Just . bimap cs id
(SFalse, SFalse, True) -> either (delayedFailFatal . serverErr) (return . Just)
in
fmap f (liftIO $ lazyRequestBody request) >>=
case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods), hasReqBody) of
(STrue, STrue, _) -> return . bimap cs id
(STrue, SFalse, _) -> either (delayedFailFatal . serverErr) return
(SFalse, STrue, False) -> return . either (const Nothing) (Just . Right)
(SFalse, SFalse, False) -> return . either (const Nothing) Just
(SFalse, STrue, True) -> return . Just . bimap cs id
(SFalse, SFalse, True) -> either (delayedFailFatal . serverErr) (return . Just)
instance
( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk

37
servant-server/test/Servant/ServerSpec.hs
View File

@ -51,10 +51,11 @@ import Servant.API
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
UVerb, Union, Verb, WithStatus (..), addHeader)
NoContent (..), NoContentVerb, NoFraming, OctetStream,
Optional, Patch, PlainText, Post, Put, QueryFlag, QueryParam,
QueryParams, Raw, RemoteHost, ReqBody, ReqBody', SourceIO,
StdMethod (..), Stream, Strict, UVerb, Union, Verb,
WithStatus (..), addHeader)
import Servant.Server
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
emptyServer, err401, err403, err404, respond, serve,
@ -501,6 +502,7 @@ fragmentSpec = do
------------------------------------------------------------------------------
type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person
:<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "meh" :> ReqBody' '[Optional, Strict] '[JSON] Person :> Put '[JSON] Integer
reqBodyApi :: Proxy ReqBodyApi
reqBodyApi = Proxy
@ -509,7 +511,7 @@ reqBodySpec :: Spec
reqBodySpec = describe "Servant.API.ReqBody" $ do
let server :: Server ReqBodyApi
server = return :<|> return . age
server = return :<|> return . age :<|> return . maybe 0 age
mkReq method x = THW.request method x
[(hContentType, "application/json;charset=utf-8")]
@ -526,6 +528,31 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
THW.request methodPost "/"
[(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
describe "optional request body" $ do
it "request without body succeeds" $ do
THW.request methodPut "/meh" [] mempty `shouldRespondWith` 200
it "request without body responds with proper default value" $ do
response <- THW.request methodPut "/meh" [] mempty
liftIO $ simpleBody response `shouldBe` encode (0 :: Integer)
it "responds with 415 if the request body media type is unsupported" $ do
THW.request methodPut "/meh" [(hContentType, "application/nonsense")]
(encode alice) `shouldRespondWith` 415
THW.request methodPut "/meh" [(hContentType, "application/octet-stream")]
(encode alice) `shouldRespondWith` 415
it "request without body and with content-type header succeeds" $ do
mkReq methodPut "/meh" mempty `shouldRespondWith` 200
it "request without body and with content-type header returns default value" $ do
response <- mkReq methodPut "/meh" mempty
liftIO $ simpleBody response `shouldBe` encode (0 :: Integer)
it "optional request body can be provided" $ do
response <- mkReq methodPut "/meh" (encode alice)
liftIO $ simpleBody response `shouldBe` encode (age alice)
-- }}}
------------------------------------------------------------------------------
-- * headerSpec {{{