From a6be2ee728f58b5eb73a6a40b784d7cec935c933 Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Sun, 4 Oct 2020 00:20:29 +0300 Subject: [PATCH 1/5] 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 a4d74564e..ad522f790 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 From a2c0a55535da62eb82fcd04156426e8cec0e68c6 Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Sun, 4 Oct 2020 05:12:32 +0300 Subject: [PATCH 2/5] Write tests for Optional ReqBody' and fix some cases --- servant-server/src/Servant/Server/Internal.hs | 22 +++++------ servant-server/test/Servant/ServerSpec.hs | 37 ++++++++++++++++--- 2 files changed, 42 insertions(+), 17 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index ad522f790..18223cc9e 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 39e75cd4a..fcc9343df 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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 {{{ From ee4baa610c50688698a293d7514f7c5239ec8464 Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Sun, 4 Oct 2020 05:44:33 +0300 Subject: [PATCH 3/5] =?UTF-8?q?Optional=20ReqBody':=20Replace=20=E2=80=9Cb?= =?UTF-8?q?imap=E2=80=9D=20with=20=E2=80=9Cfirst=E2=80=9D?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- servant-server/src/Servant/Server/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 18223cc9e..e696df706 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -41,7 +41,7 @@ import Control.Monad.Trans import Control.Monad.Trans.Resource (runResourceT) import Data.Bifunctor - (bimap) + (first) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 @@ -691,11 +691,11 @@ instance ( AllCTUnrender list a, HasServer api context in fmap f (liftIO $ lazyRequestBody request) >>= case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods), hasReqBody) of - (STrue, STrue, _) -> return . bimap cs id + (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 . bimap cs id + (SFalse, STrue, True) -> return . Just . first cs (SFalse, SFalse, True) -> either (delayedFailFatal . serverErr) (return . Just) instance From 838623a0df1f743ee86663b243eef3a04243418b Mon Sep 17 00:00:00 2001 From: Deniz Alp Durmaz Date: Tue, 29 Nov 2022 10:33:33 +0200 Subject: [PATCH 4/5] Explicitly import GenericMode typeclass method --- servant-server/example/greet.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 0b994cd36..64b39f601 100644 --- a/servant-server/example/greet.hs +++ b/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 From 695ad19943b76bc9d36ef61be7ed57b70fa0d853 Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Tue, 29 Nov 2022 16:50:04 +0200 Subject: [PATCH 5/5] =?UTF-8?q?Fix=20missing=20=E2=80=9CrequestBodyLength?= =?UTF-8?q?=E2=80=9D=20import?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- servant-server/src/Servant/Server/Internal.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index e696df706..1bdf9703c 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -70,8 +70,9 @@ import Network.Socket import Network.Wai (Application, Request, RequestBodyLength (KnownLength), httpVersion, isSecure, lazyRequestBody, - queryString, remoteHost, getRequestBodyChunk, requestHeaders, - requestMethod, responseLBS, responseStream, vault) + queryString, remoteHost, getRequestBodyChunk, + requestBodyLength, requestHeaders, requestMethod, responseLBS, + responseStream, vault) import Prelude () import Prelude.Compat import Servant.API