From a6be2ee728f58b5eb73a6a40b784d7cec935c933 Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Sun, 4 Oct 2020 00:20:29 +0300 Subject: [PATCH] Fix Optional ReqBody' See https://github.com/haskell-servant/servant/issues/1346 --- servant-server/src/Servant/Server/Internal.hs | 75 +++++++++++++------ 1 file changed, 53 insertions(+), 22 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a4d74564..ad522f79 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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 - -- 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 + + let + hasReqBody = + case requestBodyLength request of + 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