eeva
/
servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge 695ad19943 into a4194dc490

This commit is contained in:
Viacheslav Lotsmanov 2022-12-25 14:10:22 +02:00 committed by GitHub
parent a4194dc490 695ad19943
commit 40c64f4566
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 89 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
servant-server/example/greet.hs
View File

@ -17,6 +17,7 @@ import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import Servant.API.Generic ((:-))
import Servant.Server.Generic ()
-- * Example

82
servant-server/src/Servant/Server/Internal.hs
View File

@ -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

37
servant-server/test/Servant/ServerSpec.hs
View File

@ -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 {{{