Fix Optional ReqBody'

See https://github.com/haskell-servant/servant/issues/1346

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
+                 (bimap)
 import qualified Data.ByteString                            as B
 import qualified Data.ByteString.Builder                    as BB
 import qualified Data.ByteString.Char8                      as BC8
@@ -45,6 +49,8 @@ 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
@@ -64,7 +70,8 @@ import           Network.HTTP.Types                         hiding
 import           Network.Socket
                  (SockAddr)
 import           Network.Wai
-                 (Application, Request, httpVersion, isSecure, lazyRequestBody,
+                 (Application, Request, RequestBodyLength (KnownLength),
+                 httpVersion, isSecure, lazyRequestBody,
                  queryString, remoteHost, getRequestBodyChunk, requestHeaders,
                  requestMethod, responseLBS, responseStream, vault)
 import           Prelude ()
@@ -632,12 +639,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 +657,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
+      ctCheck = withRequest $ \ request ->
-        -- See HTTP RFC 2616, section 7.2.1
+        let
-        -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
+          contentTypeH = lookup hContentType $ requestHeaders request
-        -- See also "W3C Internet Media Type registration, consistency of use"
+
-        -- http://www.w3.org/2001/tag/2002/0129-mime
+          -- See HTTP RFC 2616, section 7.2.1
-        let contentTypeH = fromMaybe "application/octet-stream"
+          -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-                         $ lookup hContentType $ requestHeaders request
+          -- See also "W3C Internet Media Type registration, consistency of use"
-        case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
+          -- http://www.w3.org/2001/tag/2002/0129-mime
-          Nothing -> delayedFail err415
+          contentTypeH' = fromMaybe "application/octet-stream" contentTypeH
-          Just f  -> return f
+
+          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
+        let
-          SFalse -> case mrqbody of
+          hasReqBody =
-            Left e  -> delayedFailFatal $ formatError rep request e
+            case requestBodyLength request of
-            Right v -> return v
+              KnownLength 0 -> False
+              _             -> True
+
+          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)
 
 instance
     ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk
@@ -824,9 +855,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 +903,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