servant-server 0.20.2 → 0.20.3.0
raw patch · 5 files changed
+309/−27 lines, 5 filesdep ~basedep ~bytestringdep ~containersnew-uploader
Dependency ranges changed: base, bytestring, containers, hspec, hspec-wai, http-api-data, servant, wai-app-static
Files
- CHANGELOG.md +34/−0
- servant-server.cabal +7/−8
- src/Servant/Server/Internal.hs +76/−6
- src/Servant/Server/Internal/Context.hs +8/−13
- src/Servant/Server/Internal/ResponseRender.hs +184/−0
CHANGELOG.md view
@@ -3,6 +3,40 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.20.3.0+--------++### Significant changes++- Remove -XStrictData from servant{,-server}'s cabal files [#1780](https://github.com/haskell-servant/servant/issues/1780) [#1781](https://github.com/haskell-servant/servant/pull/1781)++ The addition of -XStrictData to servant.cabal and servant-server.cabal reduced the laziness+ of routing, which would trigger unimplemented endpoints using `error` or `undefined`,+ despite the fact that these endpoints themselves were not queried.++### Other changes++- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811)++ Implement Server-sent events (SSE) for the Servant client using a new+ combinator "ServerSentEvents". The raw event messages, accumulated events and+ JSON-processed events can be exposed.++- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804)++ Expose MultiVerb, a more ergonomic way of defining endpoints that return+ many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html++- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800)++ Adding a Host combinator allows servant users to select APIs according+ to the Host header provided by clients.++- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706)+- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778)+- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805)+- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784)+ 0.20.2 ----
servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: servant-server-version: 0.20.2+version: 0.20.3.0 synopsis: A family of combinators for defining webservices APIs and serving them @@ -26,8 +26,7 @@ 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple-tested-with:- GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2 || ==9.10.1+tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 extra-source-files: CHANGELOG.md@@ -70,7 +69,6 @@ RankNTypes RecordWildCards ScopedTypeVariables- StrictData TupleSections TypeApplications TypeFamilies@@ -103,8 +101,9 @@ Servant.Server.Internal.DelayedIO Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler- Servant.Server.Internal.Router+ Servant.Server.Internal.ResponseRender Servant.Server.Internal.RouteResult+ Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles@@ -116,10 +115,10 @@ -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends:- , base >=4.14 && <4.21- , bytestring >=0.10.8.1 && <0.13+ , base >= 4.16.4.0 && < 4.22+ , bytestring >=0.11 && <0.13 , constraints >=0.2 && <0.15- , containers >=0.5.7.1 && <0.8+ , containers >=0.6.5.1 && <0.9 , filepath >=1.4.1.1 && <1.6 , mtl ^>=2.2.2 || ^>=2.3.1 , text >=1.2.3.0 && <2.2
src/Servant/Server/Internal.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} module Servant.Server.Internal ( module Servant.Server.Internal@@ -15,7 +16,7 @@ ) where import Control.Monad- (join, when)+ (join, when, unless) import Control.Monad.Trans (liftIO, lift) import Control.Monad.Trans.Resource@@ -42,18 +43,18 @@ import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, ErrorMessage (..), symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding- (Header, ResponseHeaders)+ (statusCode, Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,- queryString, remoteHost, getRequestBodyChunk, requestHeaders,+ queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestHeaderHost, requestMethod, responseLBS, responseStream, vault) import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', CaptureAll, DeepQuery, Description, EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..),- Header', If, IsSecure (..), NoContentVerb, QueryFlag,+ Host, Header', If, IsSecure (..), NoContentVerb, QueryFlag, QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,@@ -87,7 +88,8 @@ import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError-+import Servant.Server.Internal.ResponseRender+import Servant.API.MultiVerb import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) class HasServer api context where@@ -459,6 +461,30 @@ <> headerName <> " failed: " <> e +instance+ ( KnownSymbol sym+ , HasServer api context+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters+ ) => HasServer (Host sym :> api) context where+ type ServerT (Host sym :> api) m = ServerT api m++ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)++ route _ context (Delayed {..}) = route (Proxy :: Proxy api) context $+ let formatError =+ headerParseErrorFormatter $ getContextEntry $ mkContextWithErrorFormatter context+ rep = typeRep (Proxy :: Proxy Host)+ targetHost = symbolVal (Proxy :: Proxy sym)+ hostCheck :: DelayedIO ()+ hostCheck = withRequest $ \req ->+ case requestHeaderHost req of+ Just hostBytes ->+ let host = BC8.unpack hostBytes+ in unless (host == targetHost) $+ delayedFail $ formatError rep req $ "Invalid host: " ++ host+ _ -> delayedFail $ formatError rep req "Host header missing"+ in Delayed { headersD = headersD <* hostCheck, .. }+ -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@.@@ -1121,3 +1147,47 @@ toServant server servantSrvN :: ServerT (ToServantApi api) n = hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM+++instance+ ( HasAcceptCheck cs,+ ResponseListRender cs as,+ AsUnion as r,+ ReflectMethod method+ ) =>+ HasServer (MultiVerb method cs as r) ctx+ where+ type ServerT (MultiVerb method cs as r) m = m r++ hoistServerWithContext _ _ f = f++ route ::+ forall env.+ Proxy (MultiVerb method cs as r) ->+ Context ctx ->+ Delayed env (Handler r) ->+ Router env+ route _ _ action = leafRouter $ \env req k -> do+ let acc = getAcceptHeader req+ action' =+ action+ `addMethodCheck` methodCheck method req+ `addAcceptCheck` acceptCheck' (Proxy @cs) acc+ runAction action' env req k $ \output -> do+ let mresp = responseListRender @cs @as acc (toUnion @as output)+ someResponseToWai <$> case mresp of+ Nothing -> FailFatal err406+ Just resp+ | allowedMethodHead method req -> pure (setEmptyBody resp)+ | otherwise -> pure resp+ where+ method = reflectMethod (Proxy @method)++class HasAcceptCheck cs where+ acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO ()++instance (AllMime cs) => HasAcceptCheck cs where+ acceptCheck' = acceptCheck++instance HasAcceptCheck '() where+ acceptCheck' _ _ = pure ()
src/Servant/Server/Internal/Context.hs view
@@ -2,18 +2,22 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Servant.Server.Internal.Context where+module Servant.Server.Internal.Context+ ( module Servant.Server.Internal.Context+ , module Servant.API.TypeLevel.List+ ) where -import Data.Kind+import Data.Kind (Type) import Data.Proxy import GHC.TypeLits+import Servant.API.TypeLevel.List+ (type (.++)) -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace@@ -48,15 +52,6 @@ instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 --- | Append two type-level lists.------ Hint: import it as------ > import Servant.Server (type (.++))-type family (.++) (l1 :: [Type]) (l2 :: [Type]) where- '[] .++ a = a- (a ': as) .++ b = a ': (as .++ b)- -- | Append two contexts. (.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2) EmptyContext .++ a = a@@ -92,7 +87,7 @@ -- to have multiple values of the same type in your 'Context' and need to access -- them, we provide 'NamedContext'. You can think of it as sub-namespaces for -- 'Context's.-data NamedContext (name :: Symbol) (subContext :: [Type])+newtype NamedContext (name :: Symbol) (subContext :: [Type]) = NamedContext (Context subContext) -- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you
+ src/Servant/Server/Internal/ResponseRender.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE EmptyCase #-}++module Servant.Server.Internal.ResponseRender where++import Data.ByteString (ByteString)+import Data.Kind (Type)+import Data.Typeable+import GHC.TypeLits+import qualified Data.ByteString.Lazy as BSL+import qualified Network.Wai as Wai+import Network.HTTP.Types (Status, hContentType)+import Data.SOP+import qualified Servant.Types.SourceT as S+import qualified Data.ByteString.Builder as BB+import qualified Data.Sequence as Seq ++import Servant.API.ContentTypes (AcceptHeader (..), AllMimeRender, MimeRender, Accept, allMimeRender, mimeRender, contentType)+import Servant.API.MultiVerb+import Servant.API.Status+import Servant.API.Stream (SourceIO)+import Servant.API.UVerb.Union+import Servant.Types.Internal.Response+import qualified Network.HTTP.Media as M+import Data.Foldable (toList)+import Data.Sequence ((<|))++class (Typeable a) => IsWaiBody a where+ responseToWai :: InternalResponse a -> Wai.Response++instance IsWaiBody BSL.ByteString where+ responseToWai r =+ Wai.responseLBS+ (statusCode r)+ (toList (headers r))+ (responseBody r)++instance IsWaiBody () where+ responseToWai r =+ Wai.responseLBS+ (statusCode r)+ (toList (headers r))+ mempty++instance IsWaiBody (SourceIO ByteString) where+ responseToWai r =+ Wai.responseStream+ (statusCode r)+ (toList (headers r))+ $ \output flush -> do+ S.foreach+ (const (pure ()))+ (\chunk -> output (BB.byteString chunk) *> flush)+ (responseBody r)++data SomeResponse = forall a. (IsWaiBody a) => SomeResponse (InternalResponse a)++class ResponseListRender cs as where+ responseListRender+ :: AcceptHeader+ -> Union (ResponseTypes as)+ -> Maybe SomeResponse+ responseListStatuses :: [Status]++instance ResponseListRender cs '[] where+ responseListRender _ x = case x of {}+ responseListStatuses = []++class (IsWaiBody (ResponseBody a)) => ResponseRender cs a where+ type ResponseStatus a :: Nat+ type ResponseBody a :: Type+ responseRender+ :: AcceptHeader+ -> ResponseType a+ -> Maybe (InternalResponse (ResponseBody a))++instance+ ( ResponseRender cs a,+ ResponseListRender cs as,+ KnownStatus (ResponseStatus a)+ ) =>+ ResponseListRender cs (a ': as)+ where+ responseListRender acc (Z (I x)) = fmap SomeResponse (responseRender @cs @a acc x)+ responseListRender acc (S x) = responseListRender @cs @as acc x++ responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as++instance+ ( AsHeaders xs (ResponseType r) a,+ ServantHeaders hs xs,+ ResponseRender cs r+ ) =>+ ResponseRender cs (WithHeaders hs a r)+ where+ type ResponseStatus (WithHeaders hs a r) = ResponseStatus r+ type ResponseBody (WithHeaders hs a r) = ResponseBody r++ responseRender acc x = addHeaders <$> responseRender @cs @r acc y+ where+ (hs, y) = toHeaders @xs x+ addHeaders r =+ r+ { headers = headers r <> Seq.fromList (constructHeaders @hs hs)+ }++instance+ ( KnownStatus s,+ MimeRender ct a+ ) =>+ ResponseRender cs (RespondAs (ct :: Type) s desc a)+ where+ type ResponseStatus (RespondAs ct s desc a) = s+ type ResponseBody (RespondAs ct s desc a) = BSL.ByteString++ responseRender _ x =+ pure . addContentType @ct $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = mimeRender (Proxy @ct) x,+ headers = mempty+ }++instance (KnownStatus s) => ResponseRender cs (RespondAs '() s desc ()) where+ type ResponseStatus (RespondAs '() s desc ()) = s+ type ResponseBody (RespondAs '() s desc ()) = ()++ responseRender _ _ =+ pure $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = (),+ headers = mempty+ }++instance+ (Accept ct, KnownStatus s)+ => ResponseRender cs (RespondStreaming s desc framing ct)+ where+ type ResponseStatus (RespondStreaming s desc framing ct) = s+ type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + responseRender _ x =+ pure . addContentType @ct $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = x,+ headers = mempty+ }++instance+ (AllMimeRender cs a, KnownStatus s)+ => ResponseRender cs (Respond s desc a) where+ type ResponseStatus (Respond s desc a) = s+ type ResponseBody (Respond s desc a) = BSL.ByteString++ -- Note: here it seems like we are rendering for all possible content types,+ -- only to choose the correct one afterwards. However, render results besides the+ -- one picked by 'M.mapAcceptMedia' are not evaluated, and therefore nor are the+ -- corresponding rendering functions.+ responseRender (AcceptHeader acc) x =+ M.mapAcceptMedia (map (uncurry mkRenderOutput) (allMimeRender (Proxy @cs) x)) acc+ where+ mkRenderOutput :: M.MediaType -> BSL.ByteString -> (M.MediaType, InternalResponse BSL.ByteString)+ mkRenderOutput c body =+ (c,) . addContentType' c $+ InternalResponse+ { statusCode = statusVal (Proxy @s),+ responseBody = body,+ headers = mempty+ }++addContentType :: forall ct a. (Accept ct) => InternalResponse a -> InternalResponse a+addContentType = addContentType' (contentType (Proxy @ct))++addContentType' :: M.MediaType -> InternalResponse a -> InternalResponse a+addContentType' c r = r {headers = (hContentType, M.renderHeader c) <| headers r}++setEmptyBody :: SomeResponse -> SomeResponse+setEmptyBody (SomeResponse r) = SomeResponse (go r)+ where+ go :: InternalResponse a -> InternalResponse BSL.ByteString+ go InternalResponse {..} = InternalResponse {responseBody = mempty, ..}++someResponseToWai :: SomeResponse -> Wai.Response+someResponseToWai (SomeResponse r) = responseToWai r