Fix Optional ReqBody' (wrap value into Maybe)

servant-server/example/greet.hs

@@ -17,6 +17,7 @@ import           Network.Wai
 import           Network.Wai.Handler.Warp
 
 import           Servant
+import           Servant.API.Generic ((:-))
 import           Servant.Server.Generic ()
 
 -- * Example

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

@@ -32,12 +32,16 @@ module Servant.Server.Internal
   , module Servant.Server.Internal.ServerError
   ) where
 
+import           Control.Applicative
+                 ((<|>))
 import           Control.Monad
                  (join, when)
 import           Control.Monad.Trans
                  (liftIO)
 import           Control.Monad.Trans.Resource
                  (runResourceT)
+import           Data.Bifunctor
+                 (first)
 import qualified Data.ByteString                            as B
 import qualified Data.ByteString.Builder                    as BB
 import qualified Data.ByteString.Char8                      as BC8
@@ -64,9 +68,11 @@ import           Network.HTTP.Types                         hiding
 import           Network.Socket
                  (SockAddr)
 import           Network.Wai
-                 (Application, Request, httpVersion, isSecure, lazyRequestBody,
-                 queryString, remoteHost, getRequestBodyChunk, requestHeaders,
-                 requestMethod, responseLBS, responseStream, vault)
+                 (Application, Request, RequestBodyLength (KnownLength),
+                 httpVersion, isSecure, lazyRequestBody,
+                 queryString, remoteHost, getRequestBodyChunk,
+                 requestBodyLength, requestHeaders, requestMethod, responseLBS,
+                 responseStream, vault)
 import           Prelude ()
 import           Prelude.Compat
 import           Servant.API
@@ -632,12 +638,13 @@ instance HasServer Raw 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
 
@@ -649,25 +656,48 @@ 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
-        -- 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) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
-          Nothing -> delayedFail err415
-          Just f  -> return f
+      ctCheck = withRequest $ \ request ->
+        let
+          contentTypeH = lookup hContentType $ requestHeaders 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
+          contentTypeH' = fromMaybe "application/octet-stream" contentTypeH
+
+          canHandleContentTypeH :: Maybe (BL.ByteString -> Either String a)
+          canHandleContentTypeH = canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH')
+
+          -- In case ReqBody' is Optional and neither request body nor Content-Type header was provided.
+          noOptionalReqBody =
+            case (sbool :: SBool (FoldRequired mods), contentTypeH, 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
 
       -- 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
+      bodyCheck f = withRequest $ \ request ->
+        let
+          hasReqBody =
+            case requestBodyLength request of
+              KnownLength 0 -> False
+              _             -> True
+
+          serverErr :: String -> ServerError
+          serverErr = formatError rep request . cs
+        in
+          fmap f (liftIO $ lazyRequestBody request) >>=
+            case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods), hasReqBody) of
+              (STrue,  STrue,  _)     -> return . first cs
+              (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 cs
+              (SFalse, SFalse, True)  -> either (delayedFailFatal . serverErr) (return . Just)
 
 instance
     ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk
@@ -824,9 +854,9 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
 -------------------------------------------------------------------------------
 
 -- Erroring instance for 'HasServer' when a combinator is not fully applied
-instance TypeError (PartialApplication 
+instance TypeError (PartialApplication
 #if __GLASGOW_HASKELL__ >= 904
-                    @(Type -> [Type] -> Constraint) 
+                    @(Type -> [Type] -> Constraint)
 #endif
                     HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
   where
@@ -872,9 +902,9 @@ type HasServerArrowTypeError a b =
 -- XXX: This omits the @context@ parameter, e.g.:
 --
 -- "There is no instance for HasServer (Bool :> …)". Do we care ?
-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub 
+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
 #if __GLASGOW_HASKELL__ >= 904
-                                         @(Type -> [Type] -> Constraint) 
+                                         @(Type -> [Type] -> Constraint)
 #endif
                                          HasServer ty) => HasServer (ty :> sub) context
 

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