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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a4d74564e..1bdf9703c 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 + (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 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 {{{