Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-servant-server for openSUSE:Factory checked in at 2022-02-11 23:09:37 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-server (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-server.new.1956 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-servant-server" Fri Feb 11 23:09:37 2022 rev:5 rq:953527 version:0.19 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-server/ghc-servant-server.changes 2021-09-10 23:41:09.570549695 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-server.new.1956/ghc-servant-server.changes 2022-02-11 23:11:34.123320674 +0100 @@ -1,0 +2,22 @@ +Wed Feb 2 13:27:41 UTC 2022 - Peter Simons <psim...@suse.com> + +- Update servant-server to version 0.19. + 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.19 + ---- + + ### Significant changes + + - Drop support for GHC < 8.6. + - Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). + - Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), + which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) + related to hash collisions. + - Add `NamedRoutes` combinator, making support for records first-class in Servant + ([#1388](https://github.com/haskell-servant/servant/pull/1388)). + - Add custom type errors for partially applied combinators + ([#1289](https://github.com/haskell-servant/servant/pull/1289), + [#1486](https://github.com/haskell-servant/servant/pull/1486)). + +------------------------------------------------------------------- Old: ---- servant-server-0.18.3.tar.gz New: ---- servant-server-0.19.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-server.spec ++++++ --- /var/tmp/diff_new_pack.VwOoT3/_old 2022-02-11 23:11:34.575321980 +0100 +++ /var/tmp/diff_new_pack.VwOoT3/_new 2022-02-11 23:11:34.579321993 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-servant-server # -# Copyright (c) 2021 SUSE LLC +# Copyright (c) 2022 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name servant-server %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.18.3 +Version: 0.19 Release: 0 Summary: A family of combinators for defining webservices APIs and serving them License: BSD-3-Clause @@ -31,6 +31,7 @@ BuildRequires: ghc-base-compat-devel BuildRequires: ghc-base64-bytestring-devel BuildRequires: ghc-bytestring-devel +BuildRequires: ghc-constraints-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-exceptions-devel BuildRequires: ghc-filepath-devel @@ -92,7 +93,7 @@ %prep %autosetup -n %{pkg_name}-%{version} -cabal-tweak-dep-ver 'base-compat' '< 0.12' '< 0.13' +cabal-tweak-dep-ver base-compat '< 0.12' '< 1' %build %ghc_lib_build ++++++ servant-server-0.18.3.tar.gz -> servant-server-0.19.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/CHANGELOG.md new/servant-server-0.19/CHANGELOG.md --- old/servant-server-0.18.3/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,24 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +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.19 +---- + +### Significant changes + +- Drop support for GHC < 8.6. +- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). +- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), + which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) + related to hash collisions. +- Add `NamedRoutes` combinator, making support for records first-class in Servant + ([#1388](https://github.com/haskell-servant/servant/pull/1388)). +- Add custom type errors for partially applied combinators + ([#1289](https://github.com/haskell-servant/servant/pull/1289), + [#1486](https://github.com/haskell-servant/servant/pull/1486)). + 0.18.3 ------ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/example/greet.hs new/servant-server-0.19/example/greet.hs --- old/servant-server-0.18.3/example/greet.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/example/greet.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -16,6 +17,8 @@ import Network.Wai.Handler.Warp import Servant +import Servant.Server.Generic () +import Servant.API.Generic -- * Example @@ -38,6 +41,14 @@ -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + :<|> NamedRoutes OtherRoutes + +data OtherRoutes mode = OtherRoutes + { version :: mode :- Get '[JSON] Int + , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text + } + deriving Generic + testApi :: Proxy TestApi testApi = Proxy @@ -48,9 +59,13 @@ -- -- Each handler runs in the 'Handler' monad. server :: Server TestApi -server = helloH :<|> postGreetH :<|> deleteGreetH +server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes + where otherRoutes = OtherRoutes {..} + + bye name = pure $ "Bye, " <> name <> " !" + version = pure 42 - where helloH name Nothing = helloH name (Just False) + helloH name Nothing = helloH name (Just False) helloH name (Just False) = return . Greet $ "Hello, " <> name helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/servant-server.cabal new/servant-server-0.19/servant-server.cabal --- old/servant-server-0.18.3/servant-server.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/servant-server.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,6 @@ -cabal-version: >=1.10 +cabal-version: 2.2 name: servant-server -version: 0.18.3 +version: 0.19 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web @@ -17,13 +17,13 @@ homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintain...@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple -tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 extra-source-files: CHANGELOG.md @@ -62,6 +62,7 @@ build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 + , constraints >= 0.2 && < 0.14 , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3 , text >= 1.2.3.0 && < 1.3 @@ -71,7 +72,7 @@ -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends: - servant >= 0.18.3 && < 0.18.4 + servant >= 0.19 , http-api-data >= 0.4.1 && < 0.4.4 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. @@ -113,7 +114,7 @@ , text build-depends: - aeson >= 1.4.1.0 && < 1.6 + aeson >= 1.4.1.0 && < 3 , warp >= 3.2.25 && < 3.4 test-suite spec @@ -156,7 +157,7 @@ -- Additional dependencies build-depends: - aeson >= 1.4.1.0 && < 1.6 + aeson >= 1.4.1.0 && < 3 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.9 , hspec-wai >= 0.10.1 && < 0.12 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/src/Servant/Server/Generic.hs new/servant-server-0.19/src/Servant/Server/Generic.hs --- old/servant-server-0.18.3/src/Servant/Server/Generic.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/src/Servant/Server/Generic.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,12 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, @@ -15,21 +13,15 @@ genericServeT, genericServeTWithContext, genericServer, - genericServerT, + genericServerT ) where import Data.Proxy (Proxy (..)) -import Servant.API.Generic import Servant.Server - --- | A type that specifies that an API record contains a server implementation. -data AsServerT (m :: * -> *) -instance GenericMode (AsServerT m) where - type AsServerT m :- api = ServerT api m - -type AsServer = AsServerT Handler +import Servant.API.Generic +import Servant.Server.Internal -- | Transform a record of routes into a WAI 'Application'. genericServe @@ -97,3 +89,4 @@ => routes (AsServerT m) -> ToServant routes (AsServerT m) genericServerT = toServant + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/src/Servant/Server/Internal/BasicAuth.hs new/servant-server-0.19/src/Servant/Server/Internal/BasicAuth.hs --- old/servant-server-0.18.3/src/Servant/Server/Internal/BasicAuth.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/src/Servant/Server/Internal/BasicAuth.hs 2001-09-09 03:46:40.000000000 +0200 @@ -12,8 +12,6 @@ import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) -import Data.Monoid - ((<>)) import Data.Typeable (Typeable) import Data.Word8 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/src/Servant/Server/Internal/ServerError.hs new/servant-server-0.19/src/Servant/Server/Internal/ServerError.hs --- old/servant-server-0.18.3/src/Servant/Server/Internal/ServerError.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/src/Servant/Server/Internal/ServerError.hs 2001-09-09 03:46:40.000000000 +0200 @@ -187,7 +187,7 @@ -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwError $ err404 { errBody = "(??????????????????? ?????????)." } +-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" } -- err404 :: ServerError err404 = ServerError { errHTTPCode = 404 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/src/Servant/Server/Internal.hs new/servant-server-0.19/src/Servant/Server/Internal.hs --- old/servant-server-0.18.3/src/Servant/Server/Internal.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/src/Servant/Server/Internal.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,23 +1,22 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 -#define HAS_TYPE_ERROR -#endif - module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth @@ -42,12 +41,11 @@ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL +import Data.Constraint (Dict(..)) import Data.Either (partitionEithers) import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) -import Data.Semigroup - ((<>)) import Data.String (IsString (..)) import Data.String.Conversions @@ -56,8 +54,9 @@ (Tagged (..), retag, untag) import qualified Data.Text as T import Data.Typeable +import GHC.Generics import GHC.TypeLits - (KnownNat, KnownSymbol, natVal, symbolVal) + (KnownNat, KnownSymbol, TypeError, symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding (Header, ResponseHeaders) @@ -77,7 +76,8 @@ QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, - WithNamedContext) + WithNamedContext, NamedRoutes) +import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime, MimeRender (..), MimeUnrender (..), NoContent, @@ -87,7 +87,10 @@ unfoldRequestArgument) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) +import Servant.API.Status + (statusFromNat) import qualified Servant.Types.SourceT as S +import Servant.API.TypeErrors import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, parseUrlPieces) @@ -103,12 +106,10 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError -#ifdef HAS_TYPE_ERROR import GHC.TypeLits (ErrorMessage (..), TypeError) import Servant.API.TypeLevel (AtLeastOneFragment, FragmentUnique) -#endif class HasServer api context where type ServerT api (m :: * -> *) :: * @@ -300,7 +301,7 @@ route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status @@ -312,7 +313,7 @@ route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) instance (ReflectMethod method) => HasServer (NoContentVerb method) context where @@ -333,7 +334,7 @@ route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) instance {-# OVERLAPPING #-} @@ -347,7 +348,7 @@ route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) => @@ -786,7 +787,7 @@ -- * helpers ct_wildcard :: B.ByteString -ct_wildcard = "*" <> "/" <> "*" -- Because CPP +ct_wildcard = "*" <> "/" <> "*" getAcceptHeader :: Request -> AcceptHeader getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders @@ -814,39 +815,15 @@ hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s ------------------------------------------------------------------------------- --- TypeError helpers +-- Custom type errors ------------------------------------------------------------------------------- -#ifdef HAS_TYPE_ERROR --- | This instance catches mistakes when there are non-saturated --- type applications on LHS of ':>'. --- --- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...") --- ... --- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. --- ...Maybe you haven't applied enough arguments to --- ...Capture' '[] "foo" --- ... --- --- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int) --- ... --- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. --- ...Maybe you haven't applied enough arguments to --- ...Capture' '[] "foo" --- ... --- -instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context +-- Erroring instance for 'HasServer' when a combinator is not fully applied +instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context where - type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) - -- it doesn't really matter what sub route we peak - route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" - hoistServerWithContext _ _ _ = id - --- Cannot have TypeError here, otherwise use of this symbol will error :) -type HasServerArrowKindError arr = - 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'." - ':$$: 'Text "Maybe you haven't applied enough arguments to" - ':$$: 'ShowType arr + type ServerT (arr :> sub) _ = TypeError (PartialApplication HasServer arr) + route = error "unreachable" + hoistServerWithContext _ _ _ _ = error "unreachable" -- | This instance prevents from accidentally using '->' instead of ':>' -- @@ -880,7 +857,15 @@ ':$$: 'ShowType a ':$$: 'Text "and" ':$$: 'ShowType b -#endif + +-- Erroring instances for 'HasServer' for unknown API combinators + +-- XXX: This omits the @context@ parameter, e.g.: +-- +-- "There is no instance for HasServer (Bool :> ???)". Do we care ? +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context + +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context -- | Ignore @'Fragment'@ in server handlers. -- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details. @@ -893,11 +878,7 @@ -- > server = getBooks -- > where getBooks :: Handler [Book] -- > getBooks = ...return all books... -#ifdef HAS_TYPE_ERROR instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context) -#else -instance (HasServer api context) -#endif => HasServer (Fragment a1 :> api) context where type ServerT (Fragment a1 :> api) m = ServerT api m @@ -907,3 +888,72 @@ -- $setup -- >>> import Servant + +-- | A type that specifies that an API record contains a server implementation. +data AsServerT (m :: * -> *) +instance GenericMode (AsServerT m) where + type AsServerT m :- api = ServerT api m + +type AsServer = AsServerT Handler + + +-- | Set of constraints required to convert to / from vanilla server types. +type GServerConstraints api m = + ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + , GServantProduct (Rep (api (AsServerT m))) + ) + +-- | This class is a necessary evil: in the implementation of 'HasServer' for +-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall +-- m. 'GServerConstraints' m@ to hold. +-- +-- We cannot require do that directly as the definition of 'GServerConstraints' +-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide +-- those type family applications behind a typeclass providing evidence for +-- @'GServerConstraints' api m@ in the form of a dictionary, and require that +-- @forall m. 'GServer' api m@ instead. +-- +-- Users shouldn't have to worry about this class, as the only possible instance +-- is provided in this module for all record APIs. + +class GServer (api :: * -> *) (m :: * -> *) where + gServerProof :: Dict (GServerConstraints api m) + +instance + ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + , GServantProduct (Rep (api (AsServerT m))) + ) => GServer api m where + gServerProof = Dict + +instance + ( HasServer (ToServantApi api) context + , forall m. Generic (api (AsServerT m)) + , forall m. GServer api m + ) => HasServer (NamedRoutes api) context where + + type ServerT (NamedRoutes api) m = api (AsServerT m) + + route + :: Proxy (NamedRoutes api) + -> Context context + -> Delayed env (api (AsServerT Handler)) + -> Router env + route _ ctx delayed = + case gServerProof @api @Handler of + Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed) + + hoistServerWithContext + :: forall m n. Proxy (NamedRoutes api) + -> Proxy context + -> (forall x. m x -> n x) + -> api (AsServerT m) + -> api (AsServerT n) + hoistServerWithContext _ pctx nat server = + case (gServerProof @api @m, gServerProof @api @n) of + (Dict, Dict) -> + fromServant servantSrvN + where + servantSrvM :: ServerT (ToServantApi api) m = + toServant server + servantSrvN :: ServerT (ToServantApi api) n = + hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/src/Servant/Server.hs new/servant-server-0.19/src/Servant/Server.hs --- old/servant-server-0.18.3/src/Servant/Server.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/src/Servant/Server.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,9 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. @@ -11,6 +12,8 @@ ( -- * Run a wai application from an API serve , serveWithContext + , serveWithContextT + , ServerContext , -- * Construct a wai Application from an API toApplication @@ -128,6 +131,15 @@ -- * Implementing Servers +-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'. +-- +-- Typically, this will add default context entries to the context. You shouldn't typically +-- need to worry about these constraints, but if you write a helper function that wraps +-- 'serveWithContext', you might need to include this constraint. +type ServerContext context = + ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters + ) + -- | 'serve' allows you to implement an API and produce a wai 'Application'. -- -- Example: @@ -157,11 +169,21 @@ -- 'defaultErrorFormatters' will always be appended to the end of the passed context, -- but if you pass your own formatter, it will override the default one. serveWithContext :: ( HasServer api context - , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters ) + , ServerContext context + ) => Proxy api -> Context context -> Server api -> Application -serveWithContext p context server = - toApplication (runRouter format404 (route p context (emptyDelayed (Route server)))) +serveWithContext p context = serveWithContextT p context id + +-- | A general 'serve' function that allows you to pass a custom context and hoisting function to +-- apply on all routes. +serveWithContextT :: + forall api context m. + (HasServer api context, ServerContext context) => + Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application +serveWithContextT p context toHandler server = + toApplication (runRouter format404 (route p context (emptyDelayed router))) where + router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context -- | Hoist server implementation. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/test/Servant/Server/ErrorSpec.hs new/servant-server-0.19/test/Servant/Server/ErrorSpec.hs --- old/servant-server-0.18.3/test/Servant/Server/ErrorSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/test/Servant/Server/ErrorSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -12,8 +12,6 @@ (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL -import Data.Monoid - ((<>)) import Data.Proxy import Data.String.Conversions (cs) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-server-0.18.3/test/Servant/ServerSpec.hs new/servant-server-0.19/test/Servant/ServerSpec.hs --- old/servant-server-0.18.3/test/Servant/ServerSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-server-0.19/test/Servant/ServerSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where @@ -28,8 +29,6 @@ (fromMaybe) import Data.Proxy (Proxy (Proxy)) -import Data.SOP - (I (..), NS (..)) import Data.String (fromString) import Data.String.Conversions @@ -699,8 +698,8 @@ Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse uverbResponseHeadersServer :: Server UVerbResponseHeadersApi -uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo" -uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar" +uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String) +uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String) uverbResponseHeadersSpec :: Spec uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
