Write tests for Optional ReqBody' and fix some cases

Author: unclechu

servant-server/src/Servant/Server/Internal.hs

@@ -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

servant-server/test/Servant/ServerSpec.hs

@@ -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 {{{