diff --git a/changelog.d/pr-1816 b/changelog.d/pr-1816 new file mode 100644 index 000000000..64e38ec15 --- /dev/null +++ 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 index 48dfcd9fe..8fb40f1ef 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -15,6 +15,7 @@ module Servant.Server.Internal , module Servant.Server.Internal.ServerError ) where +import Control.Applicative ((<|>)) import Control.Monad (join, when, unless) import Control.Monad.Trans @@ -22,6 +23,8 @@ import Control.Monad.Trans 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 index 7822cf1f8..e2270f517 100644 --- 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 {{{