diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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 () diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs --- a/src/Servant/Server/Internal/Context.hs +++ b/src/Servant/Server/Internal/Context.hs @@ -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 diff --git a/src/Servant/Server/Internal/ResponseRender.hs b/src/Servant/Server/Internal/ResponseRender.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/ResponseRender.hs @@ -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