servant-server 0.18.3 → 0.19
raw patch · 10 files changed
+190/−96 lines, 10 filesdep +constraintsdep ~aesondep ~servantdep ~textnew-uploader
Dependencies added: constraints
Dependency ranges changed: aeson, servant, text
Files
- CHANGELOG.md +18/−0
- example/greet.hs +17/−2
- servant-server.cabal +8/−7
- src/Servant/Server.hs +31/−9
- src/Servant/Server/Generic.hs +11/−18
- src/Servant/Server/Internal.hs +101/−51
- src/Servant/Server/Internal/BasicAuth.hs +0/−2
- src/Servant/Server/Internal/ServerError.hs +1/−1
- test/Servant/Server/ErrorSpec.hs +0/−2
- test/Servant/ServerSpec.hs +3/−4
CHANGELOG.md view
@@ -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 ------
example/greet.hs view
@@ -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 {..} - where helloH name Nothing = helloH name (Just False)+ bye name = pure $ "Bye, " <> name <> " !"+ version = pure 42++ helloH name Nothing = helloH name (Just False) helloH name (Just False) = return . Greet $ "Hello, " <> name helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
servant-server.cabal view
@@ -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-maintainers@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
src/Servant/Server.hs view
@@ -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.
src/Servant/Server/Generic.hs view
@@ -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+
src/Servant/Server/Internal.hs view
@@ -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,8 +857,16 @@ ':$$: '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
src/Servant/Server/Internal/BasicAuth.hs view
@@ -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
src/Servant/Server/Internal/ServerError.hs view
@@ -187,7 +187,7 @@ -- Example: -- -- > failingHandler :: Handler ()--- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }+-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" } -- err404 :: ServerError err404 = ServerError { errHTTPCode = 404
test/Servant/Server/ErrorSpec.hs view
@@ -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)
test/Servant/ServerSpec.hs view
@@ -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