Fix Optional ReqBody' (wrap value into Maybe), updated (#1816)

PPKFS · web-flow · commit a6cbb9c90c97 · 2025-06-05T14:32:12.000+02:00
* Port the optional ReqBody' fix from 0.19 to 0.20+

* Create pr-1816

* Update pr-1816
diff --git a/changelog.d/pr-1816 b/changelog.d/pr-1816
@@ -0,0 +1,7 @@
+synopsis: Make Optional ReqBody wrap its type into Maybe
+packages: servant
+prs: #1816
+issues: #1346
+description: {
+  Make Optional ReqBody wrap its type into Maybe
+}
diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
@@ -15,13 +15,16 @@ module Servant.Server.Internal
   , module Servant.Server.Internal.ServerError
   ) where
 
+import           Control.Applicative ((<|>))
 import           Control.Monad
                  (join, when, unless)
 import           Control.Monad.Trans
                  (liftIO, lift)
 import           Control.Monad.Trans.Resource
                  (runResourceT, ReleaseKey)
 import           Data.Acquire
+
+import Data.Bifunctor (first)
 import qualified Data.ByteString                            as B
 import qualified Data.ByteString.Builder                    as BB
 import qualified Data.ByteString.Char8                      as BC8
@@ -47,8 +50,8 @@ import           Network.HTTP.Types                         hiding
 import           Network.Socket
                  (SockAddr)
 import           Network.Wai
-                 (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
-                 queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestHeaderHost,
+                 (Application, Request, Response, ResponseReceived, RequestBodyLength (..), httpVersion, isSecure, lazyRequestBody,
+                 queryString, remoteHost, getRequestBodyChunk, requestBodyLength, requestHeaders, requestHeaderHost,
                  requestMethod, responseLBS, responseStream, vault)
 import           Servant.API
                  ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
@@ -802,12 +805,13 @@ instance HasServer RawM context where
 -- > server = postBook
 -- >   where postBook :: Book -> Handler Book
 -- >         postBook book = ...insert into your db...
-instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
+instance ( AllCTUnrender list a, HasServer api context
+         , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
          , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
          ) => HasServer (ReqBody' mods list a :> api) context where
 
   type ServerT (ReqBody' mods list a :> api) m =
-    If (FoldLenient mods) (Either String a) a -> ServerT api m
+    RequestArgument mods a -> ServerT api m
 
   hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
 
@@ -819,25 +823,44 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
       formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
 
       -- Content-Type check, we only lookup we can try to parse the request body
-      ctCheck = withRequest $ \ request -> do
+      ctCheck = withRequest $ \ request ->
         -- See HTTP RFC 2616, section 7.2.1
         -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
         -- See also "W3C Internet Media Type registration, consistency of use"
         -- http://www.w3.org/2001/tag/2002/0129-mime
-        let contentTypeH = fromMaybe "application/octet-stream"
-                         $ lookup hContentType $ requestHeaders request
-        case canHandleCTypeH (Proxy :: Proxy list) (BSL.fromStrict contentTypeH) :: Maybe (BSL.ByteString -> Either String a) of
-          Nothing -> delayedFail err415
-          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)
-        case sbool :: SBool (FoldLenient mods) of
-          STrue -> return mrqbody
-          SFalse -> case mrqbody of
-            Left e  -> delayedFailFatal $ formatError rep request e
-            Right v -> return v
+        let contentTypeHMaybe = lookup hContentType $ requestHeaders request
+            contentTypeH = fromMaybe "application/octet-stream" contentTypeHMaybe
+            canHandleContentTypeH :: Maybe (BSL.ByteString -> Either String a)
+            canHandleContentTypeH = canHandleCTypeH (Proxy :: Proxy list) (BSL.fromStrict contentTypeH)
+
+          -- In case ReqBody' is Optional and neither request body nor Content-Type header was provided.
+            noOptionalReqBody =
+              case (sbool :: SBool (FoldRequired mods), contentTypeHMaybe, requestBodyLength request) of
+                  (SFalse, Nothing, KnownLength 0) -> Just . const $ Left "This value does not matter (it is ignored)"
+                  _ -> Nothing
+        in
+          case canHandleContentTypeH <|> noOptionalReqBody of
+            Nothing -> delayedFail err415
+            Just f  -> return f
+
+      bodyCheck f = withRequest $ \ request ->
+        let
+          hasReqBody =
+            case requestBodyLength request of
+              KnownLength 0 -> False
+              _             -> True
+
+          serverErr :: String -> ServerError
+          serverErr = formatError rep request
+        in
+          fmap f (liftIO $ lazyRequestBody request) >>=
+            case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods), hasReqBody) of
+              (STrue,  STrue,  _)     -> return . first T.pack
+              (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 . first T.pack
+              (SFalse, SFalse, True)  -> either (delayedFailFatal . serverErr) (return . Just)
 
 instance
     ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk
diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs
@@ -62,7 +62,7 @@ import           Servant.API
                  IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
                  NoFraming, OctetStream, Patch, PlainText, Post, Put,
                  QueryFlag, QueryParam, QueryParams, QueryString, Raw,
-                 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
+                 RemoteHost, ReqBody, ReqBody', SourceIO, StdMethod (..), Stream, Strict,
                  UVerb, Union, Verb, WithStatus (..), addHeader, addHeader')
 import           Servant.API.QueryString (FromDeepQuery(..))
 import           Servant.Server
@@ -580,6 +580,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
@@ -588,7 +589,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")]
 
@@ -603,6 +604,31 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
     it "responds with 415 if the request body media type is unsupported" $ 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 {{{
