servant 0.19.1 → 0.20.3.0
raw patch · 41 files changed
Files
- CHANGELOG.md +100/−0
- servant.cabal +113/−90
- src/Servant/API.hs +25/−8
- src/Servant/API/Alternative.hs +5/−9
- src/Servant/API/BasicAuth.hs +4/−2
- src/Servant/API/Capture.hs +4/−2
- src/Servant/API/ContentTypes.hs +33/−41
- src/Servant/API/Description.hs +3/−1
- src/Servant/API/Empty.hs +1/−4
- src/Servant/API/Experimental/Auth.hs +1/−1
- src/Servant/API/Fragment.hs +4/−2
- src/Servant/API/Generic.hs +4/−1
- src/Servant/API/Header.hs +3/−1
- src/Servant/API/Host.hs +13/−0
- src/Servant/API/Modifiers.hs +6/−3
- src/Servant/API/MultiVerb.hs +500/−0
- src/Servant/API/NamedRoutes.hs +3/−1
- src/Servant/API/QueryParam.hs +5/−3
- src/Servant/API/QueryString.hs +86/−0
- src/Servant/API/Range.hs +68/−0
- src/Servant/API/Raw.hs +3/−0
- src/Servant/API/ReqBody.hs +3/−1
- src/Servant/API/ResponseHeaders.hs +66/−45
- src/Servant/API/ServerSentEvents.hs +37/−0
- src/Servant/API/Stream.hs +8/−6
- src/Servant/API/Sub.hs +3/−1
- src/Servant/API/TypeErrors.hs +20/−1
- src/Servant/API/TypeLevel.hs +24/−15
- src/Servant/API/TypeLevel/List.hs +14/−0
- src/Servant/API/UVerb.hs +11/−7
- src/Servant/API/UVerb/Union.hs +11/−8
- src/Servant/API/Verbs.hs +4/−2
- src/Servant/API/WithNamedContext.hs +3/−1
- src/Servant/API/WithResource.hs +3/−0
- src/Servant/Links.hs +84/−42
- src/Servant/Test/ComprehensiveAPI.hs +1/−0
- src/Servant/Types/Internal/Response.hs +17/−0
- src/Servant/Types/SourceT.hs +41/−23
- test/Servant/API/ContentTypesSpec.hs +17/−25
- test/Servant/API/ResponseHeadersSpec.hs +19/−0
- test/Servant/LinksSpec.hs +94/−1
CHANGELOG.md view
@@ -2,6 +2,106 @@ 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++- Exported addQueryParam [#1232](https://github.com/haskell-servant/servant/issues/1232) [#1785](https://github.com/haskell-servant/servant/pull/1785)++ `addQueryParams` is required to define custom `HasLink` instances which actually manipulate the+ generated query params. This function was not exported earlier and now it is.++- 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.++- Use newtype deriving for ToHttpApiData in the type Range [#1813](https://github.com/haskell-servant/servant/pull/1813)++- 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) [#1814](https://github.com/haskell-servant/servant/pull/1814)++0.20.2+----+- Full query string helpers [#1604](https://github.com/haskell-servant/servant/pull/1604)++ This PR introduces `DeepQuery`, a route combinator that implements a pattern commonly known as deep objects.+ It builds upon the convention of using `[]` for a list of parameters: + `books?filter[search]=value&filter[author][name]=value`.+ The corresponding type would be `DeepQuery "filter" BookQuery :> Get '[JSON] [Book]`.+- Add IsIn instance for NamedRoutes [#1707](https://github.com/haskell-servant/servant/pull/1707)+- Renamed `AtLeastOneFragment` type class to `AtMostOneFragment` [#1727](https://github.com/haskell-servant/servant/pull/1727)++ The previously named `AtLeastOneFragment` type class defined in the+ `Servant.API.TypeLevel` module has been renamed to `AtMostOneFragment`,+ since the previous name was misleading.+- Use `Header'` in response headers. [#1697](https://github.com/haskell-servant/servant/pull/1697)++ Use `Header'` instead of `Header` in response, so it's possible to provide+ `Description`, for example:++ ```+ type PaginationTotalCountHeader =+ Header'+ '[ Description "Indicates to the client total count of items in collection"+ , Optional+ , Strict+ ]+ "Total-Count"+ Int+ ```++ Note: if you want to add header with description you should use `addHeader'`+ or `noHeader'` which accepts `Header'` with all modifiers.+++0.20.1+----++- Support aeson-2.2 [#1695](https://github.com/haskell-servant/servant/pull/1695)++0.20+----++- Headers support in UVerb responses [#1570](https://github.com/haskell-servant/servant/issues/1570) [#1571](https://github.com/haskell-servant/servant/pull/1571)+- Generalize type of `Servant.Types.SourceT.source` to any foldable [#1593](https://github.com/haskell-servant/servant/pull/1593)+- Make `Mime(Un)Render PlainText String` instances encode/decode UTF-8 [#1645](https://github.com/haskell-servant/servant/issues/1645)+- Add HasStatus instance for Headers (that defers StatusOf to underlying value) [#1649](https://github.com/haskell-servant/servant/pull/1649)+- Make fromSourceIO run in IO [#1661](https://github.com/haskell-servant/servant/pull/1661)++ Some streaming abstractions, like io-streams, require stateful+ initialization. Since all actual call sites of `fromSourceIO`+ are in a context where `IO` actions can be executed, these+ streaming sources can be accomodated by having letting+ `fromSourceIO` run in `IO`.++ To migrate your existing `FromSourceIO` instance, simply put+ a `pure`/`return` in front of it.++- Fix the handling of multiple headers with the same name. [#1666](https://github.com/haskell-servant/servant/pull/1666)+ 0.19.1 ------
servant.cabal view
@@ -1,9 +1,8 @@-cabal-version: 2.2-name: servant-version: 0.19.1--synopsis: A family of combinators for defining webservices APIs-category: Servant, Web+cabal-version: 3.0+name: servant+version: 0.20.3.0+synopsis: A family of combinators for defining webservices APIs+category: Servant, Web description: A family of combinators for defining webservices APIs and serving them .@@ -11,26 +10,73 @@ . <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG> -homepage: http://docs.servant.dev/-bug-reports: http://github.com/haskell-servant/servant/issues-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+homepage: http://docs.servant.dev/+bug-reports: http://github.com/haskell-servant/servant/issues+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 -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1- , GHCJS ==8.6.0.1+build-type: Simple+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+extra-source-files: CHANGELOG.md source-repository head- type: git+ type: git location: http://github.com/haskell-servant/servant.git +common extensions+ default-extensions:+ AllowAmbiguousTypes+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ NoStarIsType+ OverloadedLabels+ OverloadedStrings+ PackageImports+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns++ default-language: Haskell2010++common ghc-options+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ -fhide-source-paths -Wno-unused-do-bind -fdicts-strict+ -Wno-unticked-promoted-constructors -Werror=unused-imports+ -Wunused-packages+ library+ import: extensions+ import: ghc-options exposed-modules: Servant.API Servant.API.Alternative@@ -43,132 +89,109 @@ Servant.API.Fragment Servant.API.Generic Servant.API.Header+ Servant.API.Host Servant.API.HttpVersion Servant.API.IsSecure Servant.API.Modifiers Servant.API.NamedRoutes Servant.API.QueryParam+ Servant.API.QueryString+ Servant.API.Range Servant.API.Raw Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders+ Servant.API.ServerSentEvents Servant.API.Status Servant.API.Stream Servant.API.Sub Servant.API.TypeErrors Servant.API.TypeLevel+ Servant.API.TypeLevel.List Servant.API.UVerb+ Servant.API.MultiVerb Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext+ Servant.API.WithResource -- Types exposed-modules: Servant.Types.SourceT+ Servant.Types.Internal.Response -- Test stuff- exposed-modules:- Servant.Test.ComprehensiveAPI+ exposed-modules: Servant.Test.ComprehensiveAPI -- Safe links- exposed-modules:- Servant.Links+ exposed-modules: Servant.Links -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends:- base >= 4.9 && < 4.18- , bytestring >= 0.10.8.1 && < 0.12- , constraints >= 0.2- , mtl >= 2.2.2 && < 2.3- , sop-core >= 0.4.0.0 && < 0.6- , transformers >= 0.5.2.0 && < 0.6- , text >= 1.2.3.0 && < 2.1-+ , base >= 4.16.4.0 && <4.22+ , bytestring >=0.11 && <0.13+ , constraints >=0.2+ , containers >=0.6.5.1 && <0.9+ , mtl ^>=2.2.2 || ^>=2.3.1+ , sop-core >=0.4.0.0 && <0.6+ , generics-sop ^>=0.5.1+ , text >=1.2.3.0 && <2.2+ , transformers >=0.5.2.0 && <0.7 -- We depend (heavily) on the API of these packages: -- i.e. re-export, or allow using without direct dependency build-depends:- http-api-data >= 0.4.1 && < 0.5.1- , singleton-bool >= 0.1.4 && < 0.1.7+ , http-api-data >=0.4.1 && <0.7+ , singleton-bool >=0.1.4 && <0.2 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- base-compat >= 0.10.5 && < 0.13- , aeson >= 1.4.1.0 && < 3- , attoparsec >= 0.13.2.2 && < 0.15- , bifunctors >= 5.5.3 && < 5.6- , case-insensitive >= 1.2.0.11 && < 1.3- , deepseq >= 1.4.2.0 && < 1.5- , http-media >= 0.7.1.3 && < 0.9- , http-types >= 0.12.2 && < 0.13- , mmorph >= 1.1.2 && < 1.3- , network-uri >= 2.6.1.0 && < 2.7- , QuickCheck >= 2.12.6.1 && < 2.15- , string-conversions >= 0.4.0.1 && < 0.5- , tagged >= 0.8.6 && < 0.9- , vault >= 0.3.1.2 && < 0.4-- hs-source-dirs: src- default-language: Haskell2010- other-extensions: AllowAmbiguousTypes- , CPP- , ConstraintKinds- , DataKinds- , DeriveDataTypeable- , DeriveGeneric- , ExplicitNamespaces- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , KindSignatures- , MultiParamTypeClasses- , OverloadedStrings- , PolyKinds- , RankNTypes- , ScopedTypeVariables- , TupleSections- , TypeFamilies- , TypeOperators- , UndecidableInstances+ , aeson >=1.4.1.0 && <2.3+ , attoparsec >=0.13.2.2 && <0.15+ , bifunctors >=5.5.3 && <5.7+ , case-insensitive >=1.2.0.11 && <1.3+ , deepseq >=1.4.2.0 && <1.6+ , http-media >=0.7.1.3 && <0.9+ , http-types >=0.12.2 && <0.13+ , mmorph >=1.1.2 && <1.3+ , network-uri >=2.6.1.0 && <2.7+ , QuickCheck >=2.12.6.1 && <2.16+ , vault >=0.3.1.2 && <0.4 - ghc-options: -Wall -Wno-redundant-constraints+ hs-source-dirs: src test-suite spec- type: exitcode-stdio-1.0- ghc-options: -Wall- default-language: Haskell2010- hs-source-dirs: test- main-is: Spec.hs+ import: extensions+ import: ghc-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs other-modules:- Servant.API.ContentTypesSpec- Servant.API.ResponseHeadersSpec- Servant.API.StreamSpec- Servant.LinksSpec+ Servant.API.ContentTypesSpec+ Servant.API.ResponseHeadersSpec+ Servant.API.StreamSpec+ Servant.LinksSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends:- base- , base-compat , aeson+ , base , bytestring , http-media , mtl+ , network-uri , servant- , string-conversions , text- , transformers -- Additional dependencies build-depends:- hspec >= 2.6.0 && < 2.10- , QuickCheck >= 2.12.6.1 && < 2.15- , quickcheck-instances >= 0.3.19 && < 0.4+ , hspec >=2.6.0 && <2.12+ , QuickCheck >=2.12.6.1 && <2.16+ , quickcheck-instances >=0.3.19 && <0.4 - build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && < 2.10+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12
src/Servant/API.hs view
@@ -14,11 +14,15 @@ module Servant.API.Capture, -- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@ module Servant.API.Header,+ -- | Matching the @Host@ header.+ module Servant.API.Host, -- | Retrieving specific headers from the request module Servant.API.HttpVersion, -- | Retrieving the HTTP version of the request module Servant.API.QueryParam, -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@+ module Servant.API.QueryString,+ -- | Retrieving the complete query string of the 'URI': @'QueryString'@ module Servant.API.Fragment, -- | Documenting the fragment of the 'URI': @'Fragment'@ module Servant.API.ReqBody,@@ -31,6 +35,8 @@ -- | Access the location for arbitrary data to be shared by applications and middleware module Servant.API.WithNamedContext, -- | Access context entries in combinators in servant-server+ module Servant.API.WithResource,+ -- | Access a managed resource scoped to a single request -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs,@@ -43,6 +49,9 @@ -- * Streaming endpoints, distinguished by HTTP method module Servant.API.Stream, + -- * Server-sent events (SSE)+ module Servant.API.ServerSentEvents,+ -- * Authentication module Servant.API.BasicAuth, @@ -101,21 +110,26 @@ (AuthProtect) import Servant.API.Fragment (Fragment)+import Servant.API.Generic+ (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,+ ToServant, ToServantApi, fromServant, genericApi, toServant) import Servant.API.Header (Header, Header')-import Servant.API.Generic- (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,- GenericServant, fromServant, toServant, genericApi)+import Servant.API.Host (Host) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) import Servant.API.Modifiers (Lenient, Optional, Required, Strict)+import Servant.API.NamedRoutes+ (NamedRoutes) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams)+import Servant.API.QueryString+ (QueryString, DeepQuery) import Servant.API.Raw- (Raw)+ (Raw, RawM) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody@@ -123,8 +137,11 @@ import Servant.API.ResponseHeaders (AddHeader, BuildHeadersTo (buildHeadersTo), GetHeaders (getHeaders), HList (..), HasResponseHeader,- Headers (..), ResponseHeader (..), addHeader, getHeadersHList,- getResponse, lookupResponseHeader, noHeader)+ Headers (..), ResponseHeader (..), addHeader, addHeader',+ getHeadersHList, getResponse, lookupResponseHeader, noHeader,+ noHeader')+import Servant.API.ServerSentEvents+ (EventKind (..), ServerSentEvents, ServerSentEvents') import Servant.API.Stream (FramingRender (..), FramingUnrender (..), FromSourceIO (..), NetstringFraming, NewlineFraming, NoFraming, SourceIO, Stream,@@ -137,8 +154,6 @@ Unique, WithStatus (..), inject, statusOf) import Servant.API.Vault (Vault)-import Servant.API.NamedRoutes- (NamedRoutes) import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,@@ -150,6 +165,8 @@ ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext)+import Servant.API.WithResource+ (WithResource) import Servant.Links (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) import Web.HttpApiData
src/Servant/API/Alternative.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where -import Control.Applicative (liftA2)+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif import Data.Biapplicative (Biapplicative (..)) import Data.Bifoldable@@ -18,8 +17,6 @@ (Bitraversable (..)) import Data.Typeable (Typeable)-import Prelude ()-import Prelude.Compat -- | Union of two APIs, first takes precedence in case of overlap. --@@ -30,7 +27,7 @@ -- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books -- :} data a :<|> b = a :<|> b- deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded)+ deriving stock (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) infixr 3 :<|> instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where@@ -38,7 +35,6 @@ instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty- (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') instance Bifoldable (:<|>) where bifoldMap f g ~(a :<|> b) = f a `mappend` g b
src/Servant/API/BasicAuth.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}+ {-# LANGUAGE PolyKinds #-} module Servant.API.BasicAuth where import Data.ByteString (ByteString)+import Data.Kind+ (Type) import Data.Typeable (Typeable) import GHC.TypeLits@@ -24,7 +26,7 @@ -- In Basic Auth, username and password are base64-encoded and transmitted via -- the @Authorization@ header. Handshakes are not required, making it -- relatively efficient.-data BasicAuth (realm :: Symbol) (userData :: *)+data BasicAuth (realm :: Symbol) (userData :: Type) deriving (Typeable) -- | A simple datatype to hold data required to decorate a request
src/Servant/API/Capture.hs view
@@ -4,6 +4,8 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Capture (Capture, Capture', CaptureAll) where +import Data.Kind+ (Type) import Data.Typeable (Typeable) import GHC.TypeLits@@ -17,7 +19,7 @@ type Capture = Capture' '[] -- todo -- | 'Capture' which can be modified. For example with 'Description'.-data Capture' (mods :: [*]) (sym :: Symbol) (a :: *)+data Capture' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving (Typeable) -- | Capture all remaining values from the request path under a certain type@@ -27,7 +29,7 @@ -- -- >>> -- GET /src/* -- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile-data CaptureAll (sym :: Symbol) (a :: *)+data CaptureAll (sym :: Symbol) (a :: Type) deriving (Typeable) -- $setup
src/Servant/API/ContentTypes.hs view
@@ -24,7 +24,7 @@ -- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Put '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@--- or @text/plain;charset-utf8@, and returns data in either one of those+-- or @text/plain;charset=utf8@, and returns data in either one of those -- formats (depending on the @Accept@ header). -- -- If you would like to support Content-Types beyond those provided here,@@ -49,6 +49,7 @@ , PlainText , FormUrlEncoded , OctetStream+ , EventStream -- * Building your own Content-Type , Accept(..)@@ -67,30 +68,25 @@ , AllMimeUnrender(..) , eitherDecodeLenient , canHandleAcceptH+ , EventStreamChunk(..) ) where import Control.Arrow (left)-import Control.Monad.Compat import Control.DeepSeq (NFData) import Data.Aeson- (FromJSON (..), ToJSON (..), encode)-import Data.Aeson.Parser- (value)-import Data.Aeson.Types- (parseEither)-import Data.Attoparsec.ByteString.Char8- (endOfInput, parseOnly, skipSpace, (<?>))+ (FromJSON (..), ToJSON (..), encode, eitherDecode)+import Data.Bifunctor+ (bimap) import qualified Data.ByteString as BS import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)-import qualified Data.ByteString.Lazy.Char8 as BC+import Data.Kind+ (Type) import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust)-import Data.String.Conversions- (cs) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL@@ -100,8 +96,6 @@ (Generic) import qualified GHC.TypeLits as TL import qualified Network.HTTP.Media as M-import Prelude ()-import Prelude.Compat import Web.FormUrlEncoded (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) @@ -110,6 +104,7 @@ data PlainText deriving Typeable data FormUrlEncoded deriving Typeable data OctetStream deriving Typeable+data EventStream deriving Typeable -- * Accept class @@ -153,6 +148,10 @@ instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" +-- | @text/event-stream@+instance Accept EventStream where+ contentType _ = "text" M.// "event-stream"+ newtype AcceptHeader = AcceptHeader BS.ByteString deriving (Eq, Show, Read, Typeable, Generic) @@ -176,7 +175,7 @@ class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -class (AllMime list) => AllCTRender (list :: [*]) a where+class (AllMime list) => AllCTRender (list :: [Type]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype).@@ -230,7 +229,7 @@ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} -class AllCTUnrender (list :: [*]) a where+class AllCTUnrender (list :: [Type]) a where canHandleCTypeH :: Proxy list -> ByteString -- Content-Type header@@ -244,12 +243,12 @@ instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where canHandleCTypeH p ctypeH =- M.mapContentMedia (allMimeUnrender p) (cs ctypeH)+ M.mapContentMedia (allMimeUnrender p) (toStrict ctypeH) -------------------------------------------------------------------------- -- * Utils (Internal) -class AllMime (list :: [*]) where+class AllMime (list :: [Type]) where allMime :: Proxy list -> [M.MediaType] instance AllMime '[] where@@ -267,7 +266,7 @@ -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeRender ---------------------------------------------------------------------------class (AllMime list) => AllMimeRender (list :: [*]) a where+class (AllMime list) => AllMimeRender (list :: [Type]) a where allMimeRender :: Proxy list -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs@@ -302,12 +301,12 @@ instance {-# OVERLAPPING #-} ( AllMime (ctyp ': ctyp' ': ctyps) ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where- allMimeRender p _ = zip (allMime p) (repeat "")+ allMimeRender p _ = map (, "") (allMime p) -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender ---------------------------------------------------------------------------class (AllMime list) => AllMimeUnrender (list :: [*]) a where+class (AllMime list) => AllMimeUnrender (list :: [Type]) a where allMimeUnrender :: Proxy list -> [(M.MediaType, ByteString -> Either String a)] @@ -350,7 +349,7 @@ -- | @BC.pack@ instance MimeRender PlainText String where- mimeRender _ = BC.pack+ mimeRender _ = TextL.encodeUtf8 . TextL.pack -- | @id@ instance MimeRender OctetStream ByteString where@@ -370,28 +369,15 @@ -------------------------------------------------------------------------- -- * MimeUnrender Instances --- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just--- objects and arrays.------ Will handle trailing whitespace, but not trailing junk. ie.------ >>> eitherDecodeLenient "1 " :: Either String Int--- Right 1+-- | Deprecated: since aeson version 0.9 `eitherDecode` has lenient behavior. ----- >>> eitherDecodeLenient "1 junk" :: Either String Int--- Left "trailing junk after valid JSON: endOfInput" eitherDecodeLenient :: FromJSON a => ByteString -> Either String a-eitherDecodeLenient input =- parseOnly parser (cs input) >>= parseEither parseJSON- where- parser = skipSpace- *> Data.Aeson.Parser.value- <* skipSpace- <* (endOfInput <?> "trailing junk after valid JSON")+eitherDecodeLenient = eitherDecode+{-# DEPRECATED eitherDecodeLenient "use eitherDecode instead" #-} -- | `eitherDecode` instance FromJSON a => MimeUnrender JSON a where- mimeUnrender _ = eitherDecodeLenient+ mimeUnrender _ = eitherDecode -- | @urlDecodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only@@ -409,16 +395,22 @@ -- | @Right . BC.unpack@ instance MimeUnrender PlainText String where- mimeUnrender _ = Right . BC.unpack+ mimeUnrender _ = bimap show TextL.unpack . TextL.decodeUtf8' -- | @Right . id@ instance MimeUnrender OctetStream ByteString where- mimeUnrender _ = Right . id+ mimeUnrender _ = Right -- | @Right . toStrict@ instance MimeUnrender OctetStream BS.ByteString where mimeUnrender _ = Right . toStrict +-- | Chunk of an event stream+newtype EventStreamChunk = EventStreamChunk+ { unEventStreamChunk :: ByteString }++instance MimeUnrender EventStream EventStreamChunk where+ mimeUnrender _ = Right . EventStreamChunk -- $setup -- >>> :set -XFlexibleInstances
src/Servant/API/Description.hs view
@@ -16,6 +16,8 @@ reflectDescription, ) where +import Data.Kind+ (Type) import Data.Proxy (Proxy (..)) import Data.Typeable@@ -59,7 +61,7 @@ type FoldDescription mods = FoldDescription' "" mods -- | Implementation of 'FoldDescription'.-type family FoldDescription' (acc :: Symbol) (mods :: [*]) :: Symbol where+type family FoldDescription' (acc :: Symbol) (mods :: [Type]) :: Symbol where FoldDescription' acc '[] = acc FoldDescription' acc (Description desc ': mods) = FoldDescription' desc mods FoldDescription' acc (mod ': mods) = FoldDescription' acc mods
src/Servant/API/Empty.hs view
@@ -2,10 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Empty(EmptyAPI(..)) where -import Data.Typeable- (Typeable)-import Prelude ()-import Prelude.Compat+import Data.Typeable (Typeable) -- | An empty API: one which serves nothing. Morally speaking, this should be -- the unit of ':<|>'. Implementors of interpretations of API types should
src/Servant/API/Experimental/Auth.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}+ {-# LANGUAGE PolyKinds #-} module Servant.API.Experimental.Auth where
src/Servant/API/Fragment.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}+ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Fragment (Fragment) where +import Data.Kind+ (Type) import Data.Typeable (Typeable) @@ -14,7 +16,7 @@ -- -- >>> -- /post#TRACKING -- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking-data Fragment (a :: *)+data Fragment (a :: Type) deriving Typeable -- $setup
src/Servant/API/Generic.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | Define servant servers from record types. Generics for the win. -- -- The usage is simple, if you only need a collection of routes. First you@@ -69,6 +70,8 @@ -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. +import Data.Kind+ (Type) import Data.Proxy (Proxy (..)) import GHC.Generics@@ -83,7 +86,7 @@ -- parameter. For example, 'AsApi' will leave @api@ untouched, while -- @'AsServerT' m@ will produce @'ServerT' api m@. class GenericMode mode where- type mode :- api :: *+ type mode :- api :: Type infixl 0 :-
src/Servant/API/Header.hs view
@@ -6,6 +6,8 @@ Header, Header', ) where +import Data.Kind+ (Type) import Data.Typeable (Typeable) import GHC.TypeLits@@ -23,7 +25,7 @@ -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer type Header = Header' '[Optional, Strict] -data Header' (mods :: [*]) (sym :: Symbol) (a :: *)+data Header' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving Typeable -- $setup
+ src/Servant/API/Host.hs view
@@ -0,0 +1,13 @@+module Servant.API.Host (Host) where++import Data.Typeable (Typeable)+import GHC.TypeLits (Symbol)++-- | Match against the given host.+--+-- This allows you to define APIs over multiple domains. For example:+--+-- > type API = Host "api1.example" :> API1+-- > :<|> Host "api2.example" :> API2+--+data Host (sym :: Symbol) deriving Typeable
src/Servant/API/Modifiers.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Servant.API.Modifiers ( -- * Required / optional argument Required, Optional,@@ -19,6 +20,8 @@ unfoldRequestArgument, ) where +import Data.Kind+ (Type) import Data.Proxy (Proxy (..)) import Data.Singletons.Bool@@ -51,7 +54,7 @@ type FoldRequired mods = FoldRequired' 'False mods -- | Implementation of 'FoldRequired'.-type family FoldRequired' (acc :: Bool) (mods :: [*]) :: Bool where+type family FoldRequired' (acc :: Bool) (mods :: [Type]) :: Bool where FoldRequired' acc '[] = acc FoldRequired' acc (Required ': mods) = FoldRequired' 'True mods FoldRequired' acc (Optional ': mods) = FoldRequired' 'False mods@@ -72,7 +75,7 @@ type FoldLenient mods = FoldLenient' 'False mods -- | Implementation of 'FoldLenient'.-type family FoldLenient' (acc :: Bool) (mods :: [*]) :: Bool where+type family FoldLenient' (acc :: Bool) (mods :: [Type]) :: Bool where FoldLenient' acc '[] = acc FoldLenient' acc (Lenient ': mods) = FoldLenient' 'True mods FoldLenient' acc (Strict ': mods) = FoldLenient' 'False mods
+ src/Servant/API/MultiVerb.hs view
@@ -0,0 +1,500 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE EmptyCase #-}++-- | MultiVerb is a part of the type-level eDSL that allows you to express complex routes+-- while retaining a high level of precision with good ergonomics.++module Servant.API.MultiVerb+ ( -- ** MultiVerb types+ MultiVerb,+ MultiVerb1,+ -- ** Response types+ Respond,+ RespondAs,+ RespondEmpty,+ RespondStreaming,+ -- ** Headers+ WithHeaders,+ DescHeader,+ OptHeader,+ AsHeaders (..),+ ServantHeaders(..),+ ServantHeader(..),+ -- ** Unions of responses+ AsUnion (..),+ eitherToUnion,+ eitherFromUnion,+ maybeToUnion,+ maybeFromUnion,+ -- ** Internal machinery+ AsConstructor (..),+ GenericAsConstructor (..),+ GenericAsUnion (..),+ ResponseType,+ ResponseTypes,+ UnrenderResult(..),+ ) where+++import Control.Applicative (Alternative(..), empty)+import Control.Monad (ap, MonadPlus(..))+import Data.ByteString (ByteString)+import Data.Kind+import Data.Proxy+import Data.SOP+import Data.Sequence (Seq(..))+import GHC.TypeLits+import Generics.SOP as GSOP+import Network.HTTP.Types as HTTP+import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader)+import qualified Data.CaseInsensitive as CI+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import Servant.API.TypeLevel.List+import Servant.API.Stream (SourceIO)+import Servant.API.UVerb.Union (Union)+import Servant.API.Header (Header')++-- | A type to describe a 'MultiVerb' response.+--+-- Includes status code, description, and return type. The content type of the+-- response is determined dynamically using the accept header and the list of+-- supported content types specified in the containing 'MultiVerb' type.+data Respond (s :: Nat) (description :: Symbol) (a :: Type)++-- | A type to describe a 'MultiVerb' response with a fixed content type.+--+-- Similar to 'Respond', but hardcodes the content type to be used for+-- generating the response. This content type is distinct from the one+-- given to 'MultiVerb', as it dictactes the response's content type, not the+-- content type request that is to be accepted.+data RespondAs responseContentType (s :: Nat) (description :: Symbol) (a :: Type)++-- | A type to describe a 'MultiVerb' response with an empty body.+--+-- Includes status code and description.+type RespondEmpty s description = RespondAs '() s description ()++-- | A type to describe a streaming 'MultiVerb' response.+--+-- Includes status code, description, framing strategy and content type. Note+-- that the handler return type is hardcoded to be 'SourceIO ByteString'.+data RespondStreaming (s :: Nat) (description :: Symbol) (framing :: Type) (ct :: Type)++-- | The result of parsing a response as a union alternative of type 'a'.+--+-- 'StatusMismatch' indicates that the response does not refer to the given+-- alternative, because the status code does not match the one produced by that+-- alternative.+--+-- 'UnrenderError' and 'UnrenderSuccess' represent respectively a failing and+-- successful parse of the response body as a value of type 'a'.+--+-- The 'UnrenderResult' type constructor has monad and alternative instances+-- corresponding to those of 'Either (Maybe (Last String)) a'.+data UnrenderResult a = StatusMismatch | UnrenderError String | UnrenderSuccess a+ deriving (Eq, Show, Functor)++instance Applicative UnrenderResult where+ pure = UnrenderSuccess+ (<*>) = ap++instance Monad UnrenderResult where+ return = pure+ StatusMismatch >>= _ = StatusMismatch+ UnrenderError e >>= _ = UnrenderError e+ UnrenderSuccess x >>= f = f x++instance Alternative UnrenderResult where+ empty = mzero+ (<|>) = mplus++instance MonadPlus UnrenderResult where+ mzero = StatusMismatch+ mplus StatusMismatch m = m+ mplus (UnrenderError e) StatusMismatch = UnrenderError e+ mplus (UnrenderError _) m = m+ mplus m@(UnrenderSuccess _) _ = m++type family ResponseType a :: Type++type instance ResponseType (Respond s description a) = a++type instance ResponseType (RespondAs responseContentType s description a) = a++type instance ResponseType (RespondStreaming s description framing ct) = SourceIO ByteString+++-- | This type adds response headers to a 'MultiVerb' response.+data WithHeaders (headers :: [Type]) (returnType :: Type) (response :: Type)++-- | This is used to convert a response containing headers to a custom type+-- including the information in the headers.+--+-- If you need to send a combination of headers and response that is not provided by Servant,+-- you can cwrite your own instance. Take example on the ones provided.+class AsHeaders headers response returnType where+ fromHeaders :: (NP I headers, response) -> returnType+ toHeaders :: returnType -> (NP I headers, response)++-- | Single-header empty response+instance AsHeaders '[a] () a where+ toHeaders a = (I a :* Nil, ())+ fromHeaders = unI . hd . fst++-- | Single-header non-empty response, return value is a tuple of the response and the header+instance AsHeaders '[h] a (a, h) where+ toHeaders (t, cc) = (I cc :* Nil, t)+ fromHeaders (I cc :* Nil, t) = (t, cc)++-- | Two headers and an empty response, return value is a tuple of the response and the header+instance AsHeaders '[a, b] () (a, b) where+ toHeaders (h1, h2) = (I h1 :* I h2 :* Nil, ())+ fromHeaders (I h1 :* I h2 :* Nil, ()) = (h1, h2)++data DescHeader (name :: Symbol) (description :: Symbol) (a :: Type)++-- | A wrapper to turn a response header into an optional one.+data OptHeader h++class ServantHeaders headers xs | headers -> xs where+ constructHeaders :: NP I xs -> [HTTP.Header]+ extractHeaders :: Seq HTTP.Header -> Maybe (NP I xs)++instance ServantHeaders '[] '[] where+ constructHeaders Nil = []+ extractHeaders _ = Just Nil++headerName :: forall name. (KnownSymbol name) => HTTP.HeaderName+headerName =+ CI.mk+ . Text.encodeUtf8+ . Text.pack+ $ symbolVal (Proxy @name)++instance+ ( KnownSymbol name,+ ServantHeader h name x,+ FromHttpApiData x,+ ServantHeaders headers xs+ ) =>+ ServantHeaders (h ': headers) (x ': xs)+ where+ constructHeaders (I x :* xs) =+ constructHeader @h x+ <> constructHeaders @headers xs++ -- NOTE: should we concatenate all the matching headers instead of just taking the first one?+ extractHeaders headers = do+ let name' = headerName @name+ (headers0, headers1) = Seq.partition (\(h, _) -> h == name') headers+ x <- case headers0 of+ Seq.Empty -> empty+ ((_, h) :<| _) -> either (const empty) pure (parseHeader h)+ xs <- extractHeaders @headers headers1+ pure (I x :* xs)++class ServantHeader h (name :: Symbol) x | h -> name x where+ constructHeader :: x -> [HTTP.Header]++instance+ (KnownSymbol name, ToHttpApiData x) =>+ ServantHeader (Header' mods name x) name x+ where+ constructHeader x = [(headerName @name, toHeader x)]++instance+ (KnownSymbol name, ToHttpApiData x) =>+ ServantHeader (DescHeader name description x) name x+ where+ constructHeader x = [(headerName @name, toHeader x)]++instance (ServantHeader h name x) => ServantHeader (OptHeader h) name (Maybe x) where+ constructHeader = foldMap (constructHeader @h)++type instance ResponseType (WithHeaders headers returnType response) = returnType+++type family ResponseTypes (as :: [Type]) where+ ResponseTypes '[] = '[]+ ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as+++-- | 'MultiVerb' produces an endpoint which can return+-- multiple values with various content types and status codes. It is similar to+-- 'Servant.API.UVerb.UVerb' and behaves similarly, but it has some important differences:+--+-- * Descriptions and statuses can be attached to individual responses without+-- using wrapper types and without affecting the handler return type.+-- * The return type of the handler can be decoupled from the types of the+-- individual responses. One can use a 'Union' type just like for 'Servant.API.UVerb.UVerb',+-- but 'MultiVerb' also supports using an arbitrary type with an 'AsUnion'+-- instance. Each response is responsible for their content type.+-- * Headers can be attached to individual responses, also without affecting+-- the handler return type.+--+-- ==== __Example__+-- Let us create an endpoint that captures an 'Int' and has the following logic:+--+-- * If the number is negative, we return status code 400 and an empty body;+-- * If the number is even, we return a 'Bool' in the response body;+-- * If the number is odd, we return another 'Int' in the response body.+--+-- > import qualified Generics.SOP as GSOP+--+-- > -- All possible HTTP responses+-- > type Responses =+-- > '[ type RespondEmpty 400 "Negative"+-- > , type Respond 200 "Even number" Bool+-- > , type Respond 200 "Odd number" Int+-- > ]+-- >+-- > -- All possible return types+-- > data Result+-- > = NegativeNumber+-- > | Odd Int+-- > | Even Bool+-- > deriving stock (Generic)+-- > deriving (AsUnion Responses)+-- > via GenericAsUnion Responses Result+-- >+-- > instance GSOP.Generic Result+--+-- These deriving statements above tie together the responses and the return values, and the order in which they are defined matters. For instance, if @Even@ and @Odd@ had switched places in the definition of @Result@, this would provoke an error:+--+--+-- > • No instance for ‘AsConstructor+-- > ((:) @Type Int ('[] @Type)) (Respond 200 "Even number" Bool)’+-- > arising from the 'deriving' clause of a data type declaration+--+-- If you would prefer to write an intance of 'AsUnion' by yourself, read more in the typeclass' documentation.+--+-- Finally, let us write our endpoint description:+--+-- > type MultipleChoicesInt =+-- > Capture "int" Int+-- > :> MultiVerb+-- > 'GET+-- > '[JSON]+-- > Responses+-- > Result+data MultiVerb (method :: StdMethod) requestMimeTypes (as :: [Type]) (responses :: Type)++-- | A 'MultiVerb' endpoint with a single response. Ideal to ensure that there can only be one response.+type MultiVerb1 method requestMimeTypes a = MultiVerb method requestMimeTypes '[a] (ResponseType a)++-- | This class is used to convert a handler return type to a union type+-- including all possible responses of a 'MultiVerb' endpoint.+--+-- Any glue code necessary to convert application types to and from the+-- canonical 'Union' type corresponding to a 'MultiVerb' endpoint should be+-- packaged into an 'AsUnion' instance.+--+-- ==== __Example__+-- Let us take the example endpoint from the 'MultiVerb' documentation. +-- There, we derived the 'AsUnion' instance with the help of Generics. +-- The manual way of implementing the instance is:+--+-- > instance AsUnion Responses Result where+-- > toUnion NegativeNumber = Z (I ())+-- > toUnion (Even b) = S (Z (I b))+-- > toUnion (Odd i) = S (S (Z (I i)))+-- > +-- > fromUnion (Z (I ())) = NegativeNumber+-- > fromUnion (S (Z (I b))) = Even b+-- > fromUnion (S (S (Z (I i)))) = Odd i+-- > fromUnion (S (S (S x))) = case x of {}+-- The last 'fromUnion' equation is here to please the pattern checker.+class AsUnion (as :: [Type]) (r :: Type) where+ toUnion :: r -> Union (ResponseTypes as)+ fromUnion :: Union (ResponseTypes as) -> r++-- | Unions can be used directly as handler return types using this trivial+-- instance.+instance (rs ~ ResponseTypes as) => AsUnion as (Union rs) where+ toUnion = id+ fromUnion = id++-- | A handler with a single response.+instance (ResponseType r ~ a) => AsUnion '[r] a where+ toUnion = Z . I+ fromUnion = unI . unZ++_foo :: Union '[Int]+_foo = toUnion @'[Respond 200 "test" Int] @Int 3++class InjectAfter as bs where+ injectAfter :: Union bs -> Union (as .++ bs)++instance InjectAfter '[] bs where+ injectAfter = id++instance (InjectAfter as bs) => InjectAfter (a ': as) bs where+ injectAfter = S . injectAfter @as @bs++class InjectBefore as bs where+ injectBefore :: Union as -> Union (as .++ bs)++instance InjectBefore '[] bs where+ injectBefore x = case x of {}++instance (InjectBefore as bs) => InjectBefore (a ': as) bs where+ injectBefore (Z x) = Z x+ injectBefore (S x) = S (injectBefore @as @bs x)++eitherToUnion ::+ forall as bs a b.+ (InjectAfter as bs, InjectBefore as bs) =>+ (a -> Union as) ->+ (b -> Union bs) ->+ (Either a b -> Union (as .++ bs))+eitherToUnion f _ (Left a) = injectBefore @as @bs (f a)+eitherToUnion _ g (Right b) = injectAfter @as @bs (g b)++class EitherFromUnion as bs where+ eitherFromUnion ::+ (Union as -> a) ->+ (Union bs -> b) ->+ (Union (as .++ bs) -> Either a b)++instance EitherFromUnion '[] bs where+ eitherFromUnion _ g = Right . g++instance (EitherFromUnion as bs) => EitherFromUnion (a ': as) bs where+ eitherFromUnion f _ (Z x) = Left (f (Z x))+ eitherFromUnion f g (S x) = eitherFromUnion @as @bs (f . S) g x++maybeToUnion ::+ forall as a.+ (InjectAfter as '[()], InjectBefore as '[()]) =>+ (a -> Union as) ->+ (Maybe a -> Union (as .++ '[()]))+maybeToUnion f (Just a) = injectBefore @as @'[()] (f a)+maybeToUnion _ Nothing = injectAfter @as @'[()] (Z (I ()))++maybeFromUnion ::+ forall as a.+ (EitherFromUnion as '[()]) =>+ (Union as -> a) ->+ (Union (as .++ '[()]) -> Maybe a)+maybeFromUnion f =+ leftToMaybe . eitherFromUnion @as @'[()] f (const (Z (I ())))+ where+ leftToMaybe = either Just (const Nothing)++-- | This class can be instantiated to get automatic derivation of 'AsUnion'+-- instances via 'GenericAsUnion'. The idea is that one has to make sure that for+-- each response @r@ in a 'MultiVerb' endpoint, there is an instance of+-- @AsConstructor xs r@ for some @xs@, and that the list @xss@ of all the+-- corresponding @xs@ is equal to 'GSOP.Code' of the handler type. Then one can+-- write:+-- @+-- type Responses = ...+-- data Result = ...+-- deriving stock (Generic)+-- deriving (AsUnion Responses) via (GenericAsUnion Responses Result)+--+-- instance GSOP.Generic Result+-- @+-- and get an 'AsUnion' instance for free.+--+-- There are a few predefined instances for constructors taking a single type+-- corresponding to a simple response, and for empty responses, but in more+-- general cases one either has to define an 'AsConstructor' instance by hand,+-- or derive it via 'GenericAsConstructor'.+class AsConstructor xs r where+ toConstructor :: ResponseType r -> NP I xs+ fromConstructor :: NP I xs -> ResponseType r++class AsConstructors xss rs where+ toSOP :: Union (ResponseTypes rs) -> SOP I xss+ fromSOP :: SOP I xss -> Union (ResponseTypes rs)++instance AsConstructors '[] '[] where+ toSOP x = case x of {}+ fromSOP x = case x of {}++instance AsConstructor '[a] (Respond code description a) where+ toConstructor x = I x :* Nil+ fromConstructor = unI . hd++instance AsConstructor '[a] (RespondAs (responseContentTypes :: Type) code description a) where+ toConstructor x = I x :* Nil+ fromConstructor = unI . hd++instance AsConstructor '[] (RespondEmpty code description) where+ toConstructor _ = Nil+ fromConstructor _ = ()++instance AsConstructor '[a] (WithHeaders headers a response) where+ toConstructor a = I a :* Nil+ fromConstructor (I a :* Nil) = a++newtype GenericAsConstructor r = GenericAsConstructor r++type instance ResponseType (GenericAsConstructor r) = ResponseType r++instance+ (GSOP.Code (ResponseType r) ~ '[xs], GSOP.Generic (ResponseType r)) =>+ AsConstructor xs (GenericAsConstructor r)+ where+ toConstructor = unZ . unSOP . GSOP.from+ fromConstructor = GSOP.to . SOP . Z++instance+ (AsConstructor xs r, AsConstructors xss rs) =>+ AsConstructors (xs ': xss) (r ': rs)+ where+ toSOP (Z (I x)) = SOP . Z $ toConstructor @xs @r x+ toSOP (S x) = SOP . S . unSOP $ toSOP @xss @rs x++ fromSOP (SOP (Z x)) = Z (I (fromConstructor @xs @r x))+ fromSOP (SOP (S x)) = S (fromSOP @xss @rs (SOP x))++-- | This type is meant to be used with @deriving via@ in order to automatically+-- generate an 'AsUnion' instance using 'Generics.SOP'. +--+-- See 'AsConstructor' for more information and examples.+newtype GenericAsUnion rs a = GenericAsUnion a++instance+ (GSOP.Code a ~ xss, GSOP.Generic a, AsConstructors xss rs) =>+ AsUnion rs (GenericAsUnion rs a)+ where+ toUnion (GenericAsUnion x) = fromSOP @xss @rs (GSOP.from x)+ fromUnion = GenericAsUnion . GSOP.to . toSOP @xss @rs++-- | A handler for a pair of empty responses can be implemented simply by+-- returning a boolean value. The convention is that the "failure" case, normally+-- represented by 'False', corresponds to the /first/ response.+instance+ AsUnion+ '[ RespondEmpty s1 desc1,+ RespondEmpty s2 desc2+ ]+ Bool+ where+ toUnion False = Z (I ())+ toUnion True = S (Z (I ()))++ fromUnion (Z (I ())) = False+ fromUnion (S (Z (I ()))) = True+ fromUnion (S (S x)) = case x of {}++-- | A handler for a pair of responses where the first is empty can be+-- implemented simply by returning a 'Maybe' value. The convention is that the+-- "failure" case, normally represented by 'Nothing', corresponds to the /first/+-- response.+instance+ {-# OVERLAPPABLE #-}+ (ResponseType r1 ~ (), ResponseType r2 ~ a) =>+ AsUnion '[r1, r2] (Maybe a)+ where+ toUnion Nothing = Z (I ())+ toUnion (Just x) = S (Z (I x))++ fromUnion (Z (I ())) = Nothing+ fromUnion (S (Z (I x))) = Just x+ fromUnion (S (S x)) = case x of {}
src/Servant/API/NamedRoutes.hs view
@@ -6,5 +6,7 @@ NamedRoutes ) where +import Data.Kind (Type)+ -- | Combinator for embedding a record of named routes into a Servant API type.-data NamedRoutes (api :: * -> *)+data NamedRoutes (api :: Type -> Type)
src/Servant/API/QueryParam.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}+ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where +import Data.Kind+ (Type) import Data.Typeable (Typeable) import GHC.TypeLits@@ -21,7 +23,7 @@ type QueryParam = QueryParam' '[Optional, Strict] -- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise.-data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *)+data QueryParam' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving Typeable -- | Lookup the values associated to the @sym@ query string parameter@@ -35,7 +37,7 @@ -- -- >>> -- /books?authors[]=<author1>&authors[]=<author2>&... -- >>> type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]-data QueryParams (sym :: Symbol) (a :: *)+data QueryParams (sym :: Symbol) (a :: Type) deriving Typeable -- | Lookup a potentially value-less query string parameter
+ src/Servant/API/QueryString.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK not-home #-}++module Servant.API.QueryString (QueryString, DeepQuery, FromDeepQuery (..), ToDeepQuery (..), generateDeepParam) where++import Data.Bifunctor (Bifunctor (first))+import Data.Kind (Type)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+ ( Typeable,+ )+import GHC.TypeLits+ ( Symbol,+ )+import Web.HttpApiData (FromHttpApiData)+import Web.Internal.HttpApiData (FromHttpApiData (..))++-- | Extract the whole query string from a request. This is useful for query strings+-- containing dynamic parameter names. For query strings with static parameter names,+-- 'QueryParam' is more suited.+--+-- Example:+--+-- >>> -- /books?author=<author name>&year=<book year>+-- >>> type MyApi = "books" :> QueryString :> Get '[JSON] [Book]+data QueryString+ deriving (Typeable)++-- | Extract an deep object from a query string.+--+-- Example:+--+-- >>> -- /books?filter[author][name]=<author name>&filter[year]=<book year>+-- >>> type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book]+data DeepQuery (sym :: Symbol) (a :: Type)+ deriving (Typeable)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> data BookQuery+-- >>> instance ToJSON Book where { toJSON = undefined }++-- | Extract a deep object from (possibly nested) query parameters.+-- a param like @filter[a][b][c]=d@ will be represented as+-- @'(["a", "b", "c"], Just "d")'@. Note that a parameter with no+-- nested field is possible: @filter=a@ will be represented as+-- @'([], Just "a")'@+class FromDeepQuery a where+ fromDeepQuery :: [([Text], Maybe Text)] -> Either String a++instance (FromHttpApiData a) => FromDeepQuery (Map Text a) where+ fromDeepQuery params =+ let parseParam ([k], Just rawV) = (k,) <$> first T.unpack (parseQueryParam rawV)+ parseParam (_, Nothing) = Left "Empty map value"+ parseParam ([], _) = Left "Empty map parameter"+ parseParam (_, Just _) = Left "Nested map values"+ in Map.fromList <$> traverse parseParam params++-- | Generate query parameters from an object, using the deep object syntax.+-- A result of @'(["a", "b", "c"], Just "d")'@ attributed to the @filter@+-- parameter name will result in the following query parameter:+-- @filter[a][b][c]=d@+class ToDeepQuery a where+ toDeepQuery :: a -> [([Text], Maybe Text)]++-- | Turn a nested path into a deep object query param+--+-- >>> generateDeepParam "filter" (["a", "b", "c"], Just "d")+-- ("filter[a][b][c]",Just "d")+generateDeepParam :: Text -> ([Text], Maybe Text) -> (Text, Maybe Text)+generateDeepParam name (keys, value) =+ let makeKeySegment key = "[" <> key <> "]"+ in (name <> foldMap makeKeySegment keys, value)
+ src/Servant/API/Range.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Servant.API.Range (Range (unRange), unsafeRange, mkRange) where++import Data.Aeson+import Data.Aeson.Types (modifyFailure)+import Data.Bifunctor (first)+import Data.Ix+import Data.Proxy (Proxy (Proxy))+import qualified Data.Text as T+import GHC.Generics (Generic)+import GHC.TypeLits+import Servant.API++-- | A newtype wrapper around 'Natural' that ensures the value is within a given range.+--+-- Example:+--+-- >>> :{+-- let validRange = mkRange 5 :: Maybe (Range 1 10)+-- in case validRange of+-- Just r -> "Valid range: " ++ show (unRange r)+-- Nothing -> "Invalid range"+-- :}+-- "Valid range: 5"+--+-- >>> :{+-- let invalidRange = mkRange 15 :: Maybe (Range 1 10)+-- in case invalidRange of+-- Just r -> "Valid range: " ++ show (unRange r)+-- Nothing -> "Invalid range"+-- :}+-- "Invalid range"+--+-- >>> decode "5" :: Maybe (Range 1 10)+-- Just (MkRange {unRange = 5})+--+-- >>> decode "15" :: Maybe (Range 1 10)+-- Nothing+newtype Range (min :: Nat) (max :: Nat) = MkRange {unRange :: Natural}+ deriving stock (Eq, Ord, Show, Generic)+ deriving newtype (Ix, ToJSON, ToHttpApiData)++unsafeRange :: Natural -> Range min max+unsafeRange = MkRange++instance (KnownNat min, KnownNat max) => Bounded (Range min max) where+ minBound = MkRange . fromInteger $ natVal (Proxy @min)+ maxBound = MkRange . fromInteger $ natVal (Proxy @max)++parseErrorMsg :: forall min max. (KnownNat min, KnownNat max) => Proxy (Range min max) -> String+parseErrorMsg _ =+ "Expecting a natural number between " <> show (natVal (Proxy @min)) <> " and " <> show (natVal (Proxy @max)) <> "."++mkRange :: forall min max. (KnownNat min, KnownNat max) => Natural -> Maybe (Range min max)+mkRange n+ | inRange (minBound :: Range min max, maxBound :: Range min max) (MkRange n) = Just (MkRange n)+ | otherwise = Nothing++instance (KnownNat min, KnownNat max) => FromJSON (Range min max) where+ parseJSON v = do+ n <- modifyFailure (const $ parseErrorMsg @min @max Proxy) $ parseJSON v+ maybe (fail $ parseErrorMsg @min @max Proxy) pure $ mkRange n++instance (KnownNat min, KnownNat max) => FromHttpApiData (Range min max) where+ parseQueryParam v = do+ n <- first (const . T.pack $ parseErrorMsg @min @max Proxy) $ parseQueryParam v+ maybe (Left . T.pack $ parseErrorMsg @min @max Proxy) Right $ mkRange n
src/Servant/API/Raw.hs view
@@ -15,3 +15,6 @@ -- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles> -- to serve static files stored in a particular directory on your filesystem data Raw deriving Typeable++-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.+data RawM deriving Typeable
src/Servant/API/ReqBody.hs view
@@ -6,6 +6,8 @@ ReqBody, ReqBody', ) where +import Data.Kind+ (Type) import Data.Typeable (Typeable) import Servant.API.Modifiers@@ -21,7 +23,7 @@ -- | -- -- /Note:/ 'ReqBody'' is always 'Required'.-data ReqBody' (mods :: [*]) (contentTypes :: [*]) (a :: *)+data ReqBody' (mods :: [Type]) (contentTypes :: [Type]) (a :: Type) deriving (Typeable) -- $setup
src/Servant/API/ResponseHeaders.hs view
@@ -1,16 +1,5 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | This module provides facilities for adding headers to a response. --@@ -23,7 +12,9 @@ , ResponseHeader (..) , AddHeader , addHeader+ , addHeader' , noHeader+ , noHeader' , HasResponseHeader , lookupResponseHeader , BuildHeadersTo(buildHeadersTo)@@ -36,8 +27,11 @@ import Control.DeepSeq (NFData (..)) import Data.ByteString.Char8 as BS- (ByteString, init, pack, unlines)+ (ByteString, pack) import qualified Data.CaseInsensitive as CI+import Data.Kind+ (Type)+import qualified Data.List as L import Data.Proxy import Data.Typeable (Typeable)@@ -47,10 +41,13 @@ import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) -import Prelude ()-import Prelude.Compat import Servant.API.Header- (Header)+ (Header')+import Servant.API.Modifiers+ (Optional, Strict)+import Servant.API.UVerb.Union+import qualified Data.SOP.BasicFunctors as SOP+import qualified Data.SOP.NS as SOP -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addOptionalHeader'.@@ -76,41 +73,38 @@ data HList a where HNil :: HList '[]- HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)+ HCons :: ResponseHeader h x -> HList xs -> HList (Header' mods h x ': xs) class NFDataHList xs where rnfHList :: HList xs -> () instance NFDataHList '[] where rnfHList HNil = ()-instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where+instance (y ~ Header' mods h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where rnfHList (HCons h xs) = rnf h `seq` rnfHList xs instance NFDataHList xs => NFData (HList xs) where rnf = rnfHList -type family HeaderValMap (f :: * -> *) (xs :: [*]) where+type family HeaderValMap (f :: Type -> Type) (xs :: [Type]) where HeaderValMap f '[] = '[]- HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs+ HeaderValMap f (Header' mods h x ': xs) = Header' mods h (f x) ': HeaderValMap f xs class BuildHeadersTo hs where buildHeadersTo :: [HTTP.Header] -> HList hs- -- ^ Note: if there are multiple occurrences of a header in the argument,- -- the values are interspersed with commas before deserialization (see- -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>) instance {-# OVERLAPPING #-} BuildHeadersTo '[] where buildHeadersTo _ = HNil +-- The current implementation does not manipulate HTTP header field lines in any way,+-- like merging field lines with the same field name in a single line. instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )- => BuildHeadersTo (Header h v ': xs) where- buildHeadersTo headers =- let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)- matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers- in case matching of- [] -> MissingHeader `HCons` buildHeadersTo headers- xs -> case parseHeader (BS.init $ BS.unlines xs) of- Left _err -> UndecodableHeader (BS.init $ BS.unlines xs)- `HCons` buildHeadersTo headers- Right h -> Header h `HCons` buildHeadersTo headers+ => BuildHeadersTo (Header' mods h v ': xs) where+ buildHeadersTo headers = case L.find wantedHeader headers of+ Nothing -> MissingHeader `HCons` buildHeadersTo headers+ Just header@(_, val) -> case parseHeader val of+ Left _err -> UndecodableHeader val `HCons` buildHeadersTo (L.delete header headers)+ Right h -> Header h `HCons` buildHeadersTo (L.delete header headers)+ where wantedHeader (h, _) = h == wantedHeaderName+ wantedHeaderName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -- * Getting headers @@ -128,7 +122,7 @@ getHeadersFromHList _ = [] instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)- => GetHeadersFromHList (Header h x ': xs)+ => GetHeadersFromHList (Header' mods h x ': xs) where getHeadersFromHList hdrs = case hdrs of Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest@@ -149,34 +143,53 @@ getHeaders' _ = [] instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)- => GetHeaders' (Header h v ': rest)+ => GetHeaders' (Header' mods h v ': rest) where getHeaders' hs = getHeadersFromHList $ getHeadersHList hs -- * Adding headers -- We need all these fundeps to save type inference-class AddHeader h v orig new- | h v orig -> new, new -> h, new -> v, new -> orig where+class AddHeader (mods :: [Type]) h v orig new+ | mods h v orig -> new, new -> mods, new -> h, new -> v, new -> orig where addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -- In this instance, we add a Header on top of something that is already decorated with some headers instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )- => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where+ => AddHeader mods h v (Headers (fst ': rest) a) (Headers (Header' mods h v ': fst ': rest) a) where addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads) -- In this instance, 'a' parameter is decorated with a Header.-instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)- => AddHeader h v a new where+instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header' mods h v] a)+ => AddHeader mods h v a new where addOptionalHeader hdr resp = Headers resp (HCons hdr HNil) +-- Instances to decorate all responses in a 'Union' with headers. The functional+-- dependencies force us to consider singleton lists as the base case in the+-- recursion (it is impossible to determine h and v otherwise from old / new+-- responses if the list is empty).+instance (AddHeader mods h v old new) => AddHeader mods h v (Union '[old]) (Union '[new]) where+ addOptionalHeader hdr resp =+ SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ resp++instance+ ( AddHeader mods h v old new, AddHeader mods h v (Union oldrest) (Union newrest)+ -- This ensures that the remainder of the response list is _not_ empty+ -- It is necessary to prevent the two instances for union types from+ -- overlapping.+ , oldrest ~ (a ': as), newrest ~ (b ': bs))+ => AddHeader mods h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where+ addOptionalHeader hdr resp = case resp of+ SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead+ SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers+ -- | @addHeader@ adds a header to a response. Note that it changes the type of -- the value in the following ways: -- -- 1. A simple value is wrapped in "Headers '[hdr]": ----- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String;--- >>> getHeaders example1+-- >>> let example0 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String;+-- >>> getHeaders example0 -- [("someheader","5")] -- -- 2. A value that already has a header has its new header *prepended* to the@@ -190,21 +203,29 @@ -- Note that while in your handlers type annotations are not required, since -- the type can be inferred from the API type, in other cases you may find -- yourself needing to add annotations.-addHeader :: AddHeader h v orig new => v -> orig -> new+addHeader :: AddHeader '[Optional, Strict] h v orig new => v -> orig -> new addHeader = addOptionalHeader . Header +-- | Same as 'addHeader' but works with `Header'`, so it's possible to use any @mods@.+addHeader' :: AddHeader mods h v orig new => v -> orig -> new+addHeader' = addOptionalHeader . Header+ -- | Deliberately do not add a header to a value. -- -- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String -- >>> getHeaders example1 -- []-noHeader :: AddHeader h v orig new => orig -> new+noHeader :: AddHeader '[Optional, Strict] h v orig new => orig -> new noHeader = addOptionalHeader MissingHeader +-- | Same as 'noHeader' but works with `Header'`, so it's possible to use any @mods@.+noHeader' :: AddHeader mods h v orig new => orig -> new+noHeader' = addOptionalHeader MissingHeader+ class HasResponseHeader h a headers where hlistLookupHeader :: HList headers -> ResponseHeader h a -instance {-# OVERLAPPING #-} HasResponseHeader h a (Header h a ': rest) where+instance {-# OVERLAPPING #-} HasResponseHeader h a (Header' mods h a ': rest) where hlistLookupHeader (HCons ha _) = ha instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where
+ src/Servant/API/ServerSentEvents.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}++-- | Server-sent events+--+-- See <https://www.w3.org/TR/2009/WD-eventsource-20090421/>.+--+module Servant.API.ServerSentEvents+ ( ServerSentEvents'+ , ServerSentEvents+ , EventKind (..)+ )+where++import Data.Kind (Type)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import GHC.TypeLits (Nat)+import Network.HTTP.Types (StdMethod (GET))++-- | Determines the shape of events you may receive (i.e. the @a@ in+-- 'ServerSentEvents\'')+data EventKind+ = RawEvent+ -- ^ 'EventMessage' or 'Event' 'ByteString'+ | JsonEvent+ -- ^ Anything that implements 'FromJSON'++-- | Server-sent events (SSE)+--+-- See <https://www.w3.org/TR/2009/WD-eventsource-20090421/>.+--+data ServerSentEvents' (method :: k) (status :: Nat) (kind :: EventKind) (a :: Type)+ deriving (Typeable, Generic)++type ServerSentEvents = ServerSentEvents' 'GET 200
src/Servant/API/Stream.hs view
@@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}++ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}@@ -45,6 +45,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.Kind+ (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy@@ -63,7 +65,7 @@ -- given @Content-Type@, delimited by a @framing@ strategy. -- Type synonyms are provided for standard methods. ---data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)+data Stream (method :: k1) (status :: Nat) (framing :: Type) (contentType :: Type) (a :: Type) deriving (Typeable, Generic) type StreamGet = Stream 'GET 200@@ -72,7 +74,7 @@ -- | A stream request body. type StreamBody = StreamBody' '[] -data StreamBody' (mods :: [*]) (framing :: *) (contentType :: *) (a :: *)+data StreamBody' (mods :: [Type]) (framing :: Type) (contentType :: Type) (a :: Type) deriving (Typeable, Generic) -------------------------------------------------------------------------------@@ -113,10 +115,10 @@ -- Pipe, etc. By implementing this class, all such streaming abstractions can -- be used directly on the client side for talking to streaming endpoints. class FromSourceIO chunk a | a -> chunk where- fromSourceIO :: SourceIO chunk -> a+ fromSourceIO :: SourceIO chunk -> IO a instance MonadIO m => FromSourceIO a (SourceT m a) where- fromSourceIO = sourceFromSourceIO+ fromSourceIO = return . sourceFromSourceIO sourceFromSourceIO :: forall m a. MonadIO m => SourceT IO a -> SourceT m a sourceFromSourceIO src =
src/Servant/API/Sub.hs view
@@ -4,6 +4,8 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Sub ((:>)) where +import Data.Kind+ (Type) import Data.Typeable (Typeable) @@ -15,7 +17,7 @@ -- >>> -- GET /hello/world -- >>> -- returning a JSON encoded World value -- >>> type MyApi = "hello" :> "world" :> Get '[JSON] World-data (path :: k) :> (a :: *)+data (path :: k) :> (a :: Type) deriving (Typeable) infixr 4 :>
src/Servant/API/TypeErrors.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-}@@ -12,9 +13,11 @@ PartialApplication, NoInstanceFor, NoInstanceForSub,+ ErrorIfNoGeneric, ) where -import Data.Kind+import Data.Kind (Type, Constraint)+import GHC.Generics (Generic(..)) import GHC.TypeLits -- | No instance exists for @tycls (expr :> ...)@ because @@ -38,3 +41,19 @@ type family Arity' (ty :: k) :: Nat where Arity' (_ -> ty) = 1 + Arity' ty Arity' _ = 0++-- see https://blog.csongor.co.uk/report-stuck-families/+type ErrorIfNoGeneric routes = Break (NoGeneric routes :: Type) (Rep (routes ()))++data T1 a++type family Break err a :: Constraint where+ Break _ T1 = ((), ())+ Break _ a = ()++type family NoGeneric (routes :: Type -> Type) where+ NoGeneric routes = TypeError+ ( 'Text "Named routes require a "+ ':<>: 'ShowType Generic ':<>: 'Text " instance for "+ ':<>: 'ShowType routes+ )
src/Servant/API/TypeLevel.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -47,23 +47,29 @@ And, -- ** Fragment FragmentUnique,- AtLeastOneFragment+ AtMostOneFragment ) where import GHC.Exts (Constraint)+import Data.Kind+ (Type) import Servant.API.Alternative (type (:<|>)) import Servant.API.Capture (Capture, CaptureAll) import Servant.API.Fragment import Servant.API.Header- (Header)+ (Header, Header') import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.ReqBody (ReqBody)+import Servant.API.NamedRoutes+ (NamedRoutes)+import Servant.API.Generic+ (ToServantApi) import Servant.API.Sub (type (:>)) import Servant.API.Verbs@@ -130,6 +136,7 @@ IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) IsElem (e :> sa) (e :> sb) = IsElem sa sb IsElem sa (Header sym x :> sb) = IsElem sa sb+ IsElem sa (Header' mods sym x :> sb) = IsElem sa sb IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) = IsElem sa sb@@ -142,6 +149,7 @@ IsElem (Verb m s ct typ) (Verb m s ct' typ) = IsSubList ct ct' IsElem e e = ()+ IsElem e (NamedRoutes rs) = IsElem e (ToServantApi rs) IsElem e a = IsElem' e a -- | Check whether @sub@ is a sub-API of @api@.@@ -176,10 +184,11 @@ -- ... -- ... Could not ... -- ...-type family IsIn (endpoint :: *) (api :: *) :: Constraint where+type family IsIn (endpoint :: Type) (api :: Type) :: Constraint where IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb) IsIn (e :> sa) (e :> sb) = IsIn sa sb IsIn e e = ()+ IsIn e (NamedRoutes record) = IsIn e (ToServantApi record) -- | Check whether @sub@ is a sub API of @api@. --@@ -235,14 +244,14 @@ -- ** Logic --- | If either a or b produce an empty constraint, produce an empty constraint.+-- | If either 'a' or 'b' produce an empty constraint, produce an empty constraint. type family Or (a :: Constraint) (b :: Constraint) :: Constraint where -- This works because of: -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap Or () b = () Or a () = () --- | If both a or b produce an empty constraint, produce an empty constraint.+-- | If both 'a' or 'b' produce an empty constraint, produce an empty constraint. type family And (a :: Constraint) (b :: Constraint) :: Constraint where And () () = () @@ -254,21 +263,21 @@ -- ** Fragment -class FragmentUnique api => AtLeastOneFragment api---- | If fragment appeared in API endpoint twice, compile-time error would be raised.+-- | If there is more than one fragment in an API endpoint,+-- a compile-time error is raised. ----- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent--- >>> instance AtLeastOneFragment FailAPI+-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent+-- >>> instance AtMostOneFragment FailAPI -- ... -- ...Only one Fragment allowed per endpoint in api... -- ...--- ...In the instance declaration for...-instance AtLeastOneFragment (Verb m s ct typ)+class FragmentUnique api => AtMostOneFragment api -instance AtLeastOneFragment (UVerb m cts as)+instance AtMostOneFragment (Verb m s ct typ) -instance AtLeastOneFragment (Fragment a)+instance AtMostOneFragment (UVerb m cts as)++instance AtMostOneFragment (Fragment a) type family FragmentUnique api :: Constraint where FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb)
+ src/Servant/API/TypeLevel/List.hs view
@@ -0,0 +1,14 @@+module Servant.API.TypeLevel.List + (type (.++)+ ) where++import Data.Kind++-- | Append two type-level lists.+--+-- Import it as+--+-- > import Servant.API.TypeLevel.List (type (.++))+type family (.++) (l1 :: [Type]) (l2 :: [Type]) where+ '[] .++ a = a+ (a ': as) .++ b = a ': (as .++ b)
src/Servant/API/UVerb.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -10,8 +10,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | An alternative to 'Verb' for end-points that respond with a resource value of any of an -- open union of types, and specific status codes for each type in this union. (`UVerb` is -- short for `UnionVerb`)@@ -33,15 +33,17 @@ ) where +import Data.Kind (Type) import Data.Proxy (Proxy (Proxy)) import GHC.TypeLits (Nat) import Network.HTTP.Types (Status, StdMethod) import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender)) import Servant.API.Status (KnownStatus, statusVal)+import Servant.API.ResponseHeaders (Headers) import Servant.API.UVerb.Union -class KnownStatus (StatusOf a) => HasStatus (a :: *) where- type StatusOf (a :: *) :: Nat+class KnownStatus (StatusOf a) => HasStatus (a :: Type) where+ type StatusOf (a :: Type) :: Nat statusOf :: forall a proxy. HasStatus a => proxy a -> Status statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))@@ -52,8 +54,8 @@ instance HasStatus NoContent where type StatusOf NoContent = 204 -class HasStatuses (as :: [*]) where- type Statuses (as :: [*]) :: [Nat]+class HasStatuses (as :: [Type]) where+ type Statuses (as :: [Type]) :: [Nat] statuses :: Proxy as -> [Status] instance HasStatuses '[] where@@ -86,6 +88,8 @@ instance KnownStatus n => HasStatus (WithStatus n a) where type StatusOf (WithStatus n a) = n +instance HasStatus a => HasStatus (Headers ls a) where+ type StatusOf (Headers ls a) = StatusOf a -- | A variant of 'Verb' that can have any of a number of response values and status codes. --@@ -97,7 +101,7 @@ -- -- Backwards compatibility is tricky, though: this type alias would mean people would have to -- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.-data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])+data UVerb (method :: StdMethod) (contentTypes :: [Type]) (as :: [Type]) instance {-# OVERLAPPING #-} MimeRender JSON a => MimeRender JSON (WithStatus _status a) where mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
src/Servant/API/UVerb/Union.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExplicitNamespaces #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}@@ -59,6 +59,7 @@ ) where +import Data.Kind (Type) import Data.Proxy (Proxy) import Data.SOP.BasicFunctors (I, unI) import Data.SOP.Constraint@@ -75,7 +76,7 @@ -- -- See also: 'matchUnion'. foldMapUnion ::- forall (c :: * -> Constraint) (a :: *) (as :: [*]).+ forall (c :: Type -> Constraint) (a :: Type) (as :: [Type]). All c as => Proxy c -> (forall x. c x => x -> a) ->@@ -88,7 +89,7 @@ -- otherwise. -- -- See also: 'foldMapUnion'.-matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a+matchUnion :: forall (a :: Type) (as :: [Type]). (IsMember a as) => Union as -> Maybe a matchUnion = fmap unI . eject -- * Stuff stolen from 'Data.WorldPeace" but for generics-sop@@ -111,8 +112,8 @@ eject (Z _) = Nothing eject (S ns) = eject ns --- | Check whether @a@ is in list. This will throw nice errors if the element is not in the--- list, or if there is a duplicate in the list.+-- | Check whether @a@ is in given type-level list.+-- This will throw a nice error if the element is not in the list. type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where CheckElemIsMember a as = If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as))@@ -128,10 +129,12 @@ ':$$: 'Text " " ':<>: 'ShowType rs type family Elem (x :: k) (xs :: [k]) :: Bool where+ Elem x (x ': _) = 'True+ Elem x (_ ': xs) = Elem x xs Elem _ '[] = 'False- Elem x (x' ': xs) =- If (x == x') 'True (Elem x xs) +-- | Check whether all values in a type-level list are distinct.+-- This will throw a nice error if there are any duplicate elements in the list. type family Unique xs :: Constraint where Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
src/Servant/API/Verbs.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE KindSignatures #-}+ {-# LANGUAGE PolyKinds #-} module Servant.API.Verbs ( module Servant.API.Verbs , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH) ) where +import Data.Kind+ (Type) import Data.Proxy (Proxy) import Data.Typeable@@ -26,7 +28,7 @@ -- provided, but you are free to define your own: -- -- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a-data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)+data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type) deriving (Typeable, Generic) -- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.
src/Servant/API/WithNamedContext.hs view
@@ -4,6 +4,8 @@ module Servant.API.WithNamedContext where import GHC.TypeLits+import Data.Kind+ (Type) -- | 'WithNamedContext' names a specific tagged context to use for the -- combinators in the API. (See also in @servant-server@,@@ -18,4 +20,4 @@ -- 'Context's are only relevant for @servant-server@. -- -- For more information, see the tutorial.-data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi+data WithNamedContext (name :: Symbol) (subContext :: [Type]) subApi
+ src/Servant/API/WithResource.hs view
@@ -0,0 +1,3 @@+module Servant.API.WithResource (WithResource) where++data WithResource res
src/Servant/Links.hs view
@@ -1,26 +1,13 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -Wno-missing-methods -Wno-redundant-constraints #-} -- | Type safe generation of internal links. -- -- Given an API with a few endpoints: ----- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators+-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators -XPolyKinds -- >>> import Servant.API -- >>> import Servant.Links -- >>> import Web.HttpApiData (toUrlPiece)@@ -128,9 +115,12 @@ , linkSegments , linkQueryParams , linkFragment+ , addQueryParam ) where -import Data.List+import Data.Kind+ (Type)+import qualified Data.List as List import Data.Constraint import Data.Proxy (Proxy (..))@@ -144,8 +134,6 @@ (KnownSymbol, TypeError, symbolVal) import Network.URI (URI (..), escapeURIString, isUnreserved)-import Prelude ()-import Prelude.Compat import Servant.API.Alternative ((:<|>) ((:<|>)))@@ -174,8 +162,10 @@ (NamedRoutes) import Servant.API.QueryParam (QueryFlag, QueryParam', QueryParams)+import Servant.API.QueryString+ (ToDeepQuery, DeepQuery, generateDeepParam, toDeepQuery) import Servant.API.Raw- (Raw)+ (Raw, RawM) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody@@ -193,13 +183,18 @@ (Verb, NoContentVerb) import Servant.API.WithNamedContext (WithNamedContext)+import Servant.API.WithResource+ (WithResource) import Web.HttpApiData-import Data.Kind- (Type)+import Servant.API.MultiVerb -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any -- 'Link' is guaranteed to be part of the mentioned API.+--+-- NOTE: If you are writing a custom 'HasLink' instance, and need to manipulate+-- the 'Link' (adding query params or fragments, perhaps), please use the the+-- 'addQueryParam' and 'addSegment' functions. data Link = Link { _segments :: [Escaped] , _queryParams :: [Param]@@ -211,7 +206,7 @@ type Fragment' = Maybe String escaped :: String -> Escaped-escaped = Escaped . escapeURIString isUnreserved+escaped = Escaped . escape getEscaped :: Escaped -> String getEscaped (Escaped s) = s@@ -245,10 +240,18 @@ addSegment :: Escaped -> Link -> Link addSegment seg l = l { _segments = _segments l <> [seg] } +-- | Add a 'Param' (query param) to a 'Link'+--+-- Please use this judiciously from within your custom 'HasLink' instances+-- to ensure that you don't end-up breaking the safe provided by "safe links" addQueryParam :: Param -> Link -> Link addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } +-- | Add a 'Fragment' (query param) to a 'Link'+--+-- Please use this judiciously from within your custom 'HasLink' instances+-- to ensure that you don't end-up breaking the safe provided by "safe links" addFragment :: Fragment' -> Link -> Link addFragment fr l = l { _fragment = fr } @@ -296,14 +299,14 @@ linkURI' addBrackets (Link segments q_params mfragment) = URI mempty -- No scheme (relative) Nothing -- Or authority (relative)- (intercalate "/" $ map getEscaped segments)+ (List.intercalate "/" $ map getEscaped segments) (makeQueries q_params) (makeFragment mfragment) where makeQueries :: [Param] -> String makeQueries [] = "" makeQueries xs =- "?" <> intercalate "&" (fmap makeQuery xs)+ "?" <> List.intercalate "&" (fmap makeQuery xs) makeQuery :: Param -> String makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)@@ -356,7 +359,7 @@ -- Note: nested APIs don't work well with this approach -- -- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link--- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *+-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: Type -- = Char -> (Int -> Link) :<|> (Double -> Link) allLinks :: forall api. HasLink api@@ -392,10 +395,11 @@ -- -- @since 0.14.1 fieldLink- :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint+ :: ( IsElem endpoint (ToServantApi routes)+ , HasLink endpoint , GenericServant routes AsApi )- => (routes AsApi -> endpoint)+ =>(routes AsApi -> endpoint) -> MkLink endpoint Link fieldLink = fieldLink' id @@ -404,10 +408,11 @@ -- @since 0.14.1 fieldLink' :: forall routes endpoint a.- ( IsElem endpoint (ToServantApi routes), HasLink endpoint+ ( IsElem endpoint (ToServantApi routes)+ , HasLink endpoint , GenericServant routes AsApi )- => (Link -> a)+ =>(Link -> a) -> (routes AsApi -> endpoint) -> MkLink endpoint a fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)@@ -415,7 +420,7 @@ -- | A type that specifies that an API record contains a set of links. -- -- @since 0.14.1-data AsLink (a :: *)+data AsLink (a :: Type) instance GenericMode (AsLink a) where type (AsLink a) :- api = MkLink api a @@ -451,7 +456,7 @@ -- | Construct a toLink for an endpoint. class HasLink endpoint where- type MkLink endpoint (a :: *)+ type MkLink endpoint (a :: Type) toLink :: (Link -> a) -> Proxy endpoint -- ^ The API endpoint you would like to point to@@ -486,7 +491,7 @@ type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a toLink toA _ l = toLink toA (Proxy :: Proxy sub) .- foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l+ List.foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l where k = symbolVal (Proxy :: Proxy sym) @@ -528,9 +533,9 @@ where type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $- foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs+ List.foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs -instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where+instance HasLink sub => HasLink (Header' mods sym (a :: Type) :> sub) where type MkLink (Header' mods sym a :> sub) r = MkLink sub r toLink = simpleToLink (Proxy :: Proxy sub) @@ -558,6 +563,10 @@ type MkLink (WithNamedContext name context sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy :: Proxy sub) +instance HasLink sub => HasLink (WithResource res :> sub) where+ type MkLink (WithResource res :> sub) a = MkLink sub a+ toLink toA _ = toLink toA (Proxy :: Proxy sub)+ instance HasLink sub => HasLink (RemoteHost :> sub) where type MkLink (RemoteHost :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub)@@ -583,6 +592,10 @@ type MkLink Raw a = a toLink toA _ = toA +instance HasLink RawM where+ type MkLink RawM a = a+ toLink toA _ = toA+ instance HasLink (Stream m status fr ct a) where type MkLink (Stream m status fr ct a) r = r toLink toA _ = toA@@ -598,7 +611,7 @@ , GenericServant routes (AsLink a) ) -class GLink (routes :: * -> *) (a :: *) where+class GLink (routes :: Type -> Type) (a :: Type) where gLinkProof :: Dict (GLinkConstraints routes a) instance GLinkConstraints routes a => GLink routes a where@@ -607,6 +620,7 @@ instance ( HasLink (ToServantApi routes) , forall a. GLink routes a+ , ErrorIfNoGeneric routes ) => HasLink (NamedRoutes routes) where type MkLink (NamedRoutes routes) a = routes (AsLink a)@@ -650,20 +664,48 @@ -- >>> import Data.Text (Text) -- Erroring instance for 'HasLink' when a combinator is not fully applied-instance TypeError (PartialApplication +instance TypeError (PartialApplication #if __GLASGOW_HASKELL__ >= 904- @(Type -> Constraint) + @(Type -> Constraint) #endif HasLink arr) => HasLink ((arr :: a -> b) :> sub) where- type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)+ type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: Type -> Constraint) arr) toLink = error "unreachable" -- Erroring instances for 'HasLink' for unknown API combinators-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub #if __GLASGOW_HASKELL__ >= 904- @(Type -> Constraint) + @(Type -> Constraint) #endif HasLink ty) => HasLink (ty :> sub) instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api++instance HasLink (MultiVerb method cs as r) where+ type MkLink (MultiVerb method cs as r) a = a+ toLink toA _ = toA++instance (KnownSymbol sym, ToDeepQuery record, HasLink sub) => HasLink (DeepQuery sym record :> sub) where+ type MkLink (DeepQuery sym record :> sub) a =+ record -> MkLink sub a++ toLink :: (KnownSymbol sym, ToDeepQuery record, HasLink sub) =>+ (Link -> a)+ -> Proxy (DeepQuery sym record :> sub)+ -> Link+ -> MkLink (DeepQuery sym record :> sub) a+ toLink toA _ lnk record =+ toLink toA (Proxy @sub) $ addParams lnk+ where+ k :: Text.Text+ k = Text.pack $ symbolVal (Proxy @sym)++ mkSingleParam :: ([Text.Text], Maybe Text.Text) -> Param+ mkSingleParam x =+ let (a, b) = generateDeepParam k x+ in SingleParam (Text.unpack a) (Text.pack $ escape $ maybe "" Text.unpack b)++ addParams :: Link -> Link+ addParams link =+ List.foldl' (flip (addQueryParam . mkSingleParam)) link $ toDeepQuery record
src/Servant/Test/ComprehensiveAPI.hs view
@@ -72,6 +72,7 @@ :<|> "description" :> Description "foo" :> GET :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET) :<|> "fragment" :> Fragment Int :> GET+ :<|> "resource" :> WithResource Int :> GET :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
+ src/Servant/Types/Internal/Response.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveTraversable #-}++-- | This module offers other servant libraries a minimalistic HTTP response type.+--+-- It is purely an internal API and SHOULD NOT be used by end-users of Servant.+module Servant.Types.Internal.Response where++import Network.HTTP.Types (Status, Header)+import Data.Sequence (Seq)+import GHC.Generics (Generic)+import Data.Data (Typeable)++data InternalResponse a = InternalResponse+ { statusCode :: Status+ , headers :: Seq Header+ , responseBody :: a+ } deriving stock (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
src/Servant/Types/SourceT.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} module Servant.Types.SourceT where import Control.Monad.Except@@ -16,15 +13,14 @@ (Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith) import Data.Functor.Identity (Identity (..))-import Prelude ()-import Prelude.Compat hiding- (readFile)+import Prelude hiding (readFile) import System.IO (Handle, IOMode (..), withFile) import qualified Test.QuickCheck as QC -- $setup--- >>> :set -XOverloadedStrings+-- >>> :set -XNoOverloadedStrings+-- >>> import Data.String (fromString) -- >>> import Control.Monad.Except (runExcept) -- >>> import Data.Foldable (toList) -- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8@@ -66,7 +62,7 @@ instance Functor m => Functor (SourceT m) where fmap f = mapStepT (fmap f) --- | >>> toList (source [1..10])+-- | >>> toList (source [1::Int .. 10]) -- [1,2,3,4,5,6,7,8,9,10] -- instance Identity ~ m => Foldable (SourceT m) where@@ -87,7 +83,7 @@ -- fromStepT (Effect (Just (Yield 1 (Yield 2 (Yield 3 Stop))))) instance MFunctor SourceT where hoist f (SourceT m) = SourceT $ \k -> k $- Effect $ f $ fmap (hoist f) $ m return+ Effect $ f $ fmap (hoist f) $ m pure -- | >>> source "xy" <> source "z" :: SourceT Identity Char -- fromStepT (Effect (Identity (Yield 'x' (Yield 'y' (Yield 'z' Stop)))))@@ -151,11 +147,17 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where showsPrec = showsPrec1 +#if !MIN_VERSION_transformers(0,6,0)+-- Since transformers-0.6, MonadTrans only works on Monads.+-- StepT isn't necesssarily a monad. It doesn't have the Monad instance.+-- See https://gitlab.haskell.org/ghc/ghc/-/issues/19922+ -- | >>> lift [1,2,3] :: StepT [] Int -- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop] -- instance MonadTrans StepT where lift = Effect . fmap (`Yield` Stop)+#endif instance MFunctor StepT where hoist f = go where@@ -189,7 +191,7 @@ | otherwise = QC.frequency [ (1, pure Stop) , (1, Skip <$> arb')- , (1, Effect . return <$> arb')+ , (1, Effect . pure <$> arb') , (8, Yield <$> QC.arbitrary <*> arb') ] where@@ -212,7 +214,7 @@ -- >>> source "foo" :: SourceT Identity Char -- fromStepT (Effect (Identity (Yield 'f' (Yield 'o' (Yield 'o' Stop))))) ---source :: [a] -> SourceT m a+source :: Foldable f => f a -> SourceT m a source = fromStepT . foldr Yield Stop -- | Get the answers.@@ -227,7 +229,7 @@ runSourceT (SourceT m) = ExceptT (m (runExceptT . runStepT)) runStepT :: Monad m => StepT m a -> ExceptT String m [a]-runStepT Stop = return []+runStepT Stop = pure [] runStepT (Error err) = throwError err runStepT (Skip s) = runStepT s runStepT (Yield x s) = fmap (x :) (runStepT s)@@ -238,9 +240,9 @@ -- Identity (Just ('f',Yield 'o' (Yield 'o' Stop))) -- uncons :: Monad m => StepT m a -> m (Maybe (a, StepT m a))-uncons Stop = return Nothing+uncons Stop = pure Nothing uncons (Skip s) = uncons s-uncons (Yield x s) = return (Just (x, s))+uncons (Yield x s) = pure (Just (x, s)) uncons (Effect ms) = ms >>= uncons uncons (Error _) = -}@@ -269,7 +271,7 @@ -- | Run action for each value in the 'SourceT'. ----- >>> foreach fail print (source "abc")+-- >>> foreach fail print $ source ("abc" :: String) -- 'a' -- 'b' -- 'c'@@ -290,12 +292,28 @@ -> StepT m a -> m () foreachStep f g = go where- go Stop = return ()+ go Stop = pure () go (Skip s) = go s go (Yield x s) = g x >> go s go (Error err) = f err go (Effect ms) = ms >>= go +-- | Traverse the 'StepT' and call the given function for each 'Yield'.+foreachYieldStep+ :: Functor m+ => (a -> StepT m b -> StepT m b)+ -> StepT m a+ -> StepT m b+foreachYieldStep f =+ go+ where+ go step = case step of+ Error msg -> Error msg+ Stop -> Stop+ Skip next -> Skip (go next)+ Yield val next -> f val (go next)+ Effect eff -> Effect (go <$> eff)+ ------------------------------------------------------------------------------- -- Monadic -------------------------------------------------------------------------------@@ -319,8 +337,8 @@ -- | Read file. -- -- >>> foreach fail BS.putStr (readFile "servant.cabal")--- cabal-version: 2.2--- name: servant+-- cabal-version: 3.0+-- name: servant -- ... -- readFile :: FilePath -> SourceT IO BS.ByteString@@ -342,16 +360,16 @@ -- -- >>> let parser = A.skipWhile A8.isSpace_w8 >> A.takeWhile1 A8.isDigit_w8 ----- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1 2 3"])+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ [fromString "1 2 3"]) -- Right ["1","2","3"] ----- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2", "3"])+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ map fromString ["1", "2", "3"]) -- Right ["123"] ----- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2 3", "4"])+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ map fromString ["1", "2 3", "4"]) -- Right ["12","34"] ----- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["foobar"])+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source [fromString "foobar"]) -- Left "Failed reading: takeWhile1" -- transformWithAtto :: Monad m => A.Parser a -> SourceT m BS.ByteString -> SourceT m a
test/Servant/API/ContentTypesSpec.hs view
@@ -8,13 +8,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where -import Prelude ()-import Prelude.Compat--import Data.Aeson- (FromJSON, ToJSON (..), Value, decode, encode, object, (.=))-import Data.ByteString.Char8- (ByteString, append, pack)+import Data.Aeson (FromJSON, ToJSON (..), Value, decode, encode, object, (.=), eitherDecode)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Either@@ -28,8 +24,6 @@ import Data.Proxy import Data.String (IsString (..))-import Data.String.Conversions- (cs) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextSE import qualified Data.Text.Lazy as TextL@@ -37,6 +31,7 @@ (evaluate) import GHC.Generics import Test.Hspec+import Network.HTTP.Media () -- for CPP import Test.QuickCheck import "quickcheck-instances" Test.QuickCheck.Instances () import Text.Read@@ -84,7 +79,7 @@ let p = Proxy :: Proxy '[JSON] it "does not render any content" $- allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))+ allMimeRender p NoContent `shouldSatisfy` all (BSL8.null . snd) it "evaluates the NoContent value" $ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall@@ -161,8 +156,7 @@ #endif let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $ addToAccept (Proxy :: Proxy JSON) b $- addToAccept (Proxy :: Proxy PlainText ) c $- ""+ addToAccept (Proxy :: Proxy PlainText ) c "" let val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText]) (acceptH a b c) (i :: Int) property $ \a b c i ->@@ -219,15 +213,13 @@ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" "foobar" `shouldBe` (Nothing :: Maybe (Either String Int)) - -- aeson >= 0.9 decodes top-level strings- describe "eitherDecodeLenient" $ do+ describe "eitherDecode is lenient" $ do + -- Since servant-0.20.1 MimeUnrender JSON instance uses eitherDecode,+ -- as aeson >= 0.9 supports decoding top-level strings and numbers. it "parses top-level strings" $ do- let toMaybe = either (const Nothing) Just- -- The Left messages differ, so convert to Maybe- property $ \x -> toMaybe (eitherDecodeLenient x)- `shouldBe` (decode x :: Maybe String)-+ property $ \x -> mimeUnrender (Proxy :: Proxy JSON) x+ `shouldBe` (eitherDecode x :: Either String String) data SomeData = SomeData { record1 :: String, record2 :: Int } deriving (Generic, Eq, Show)@@ -246,13 +238,13 @@ arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] instance MimeRender OctetStream Int where- mimeRender _ = cs . show+ mimeRender _ = BSL8.pack . show instance MimeRender PlainText Int where- mimeRender _ = cs . show+ mimeRender _ = BSL8.pack . show instance MimeRender PlainText ByteString where- mimeRender _ = cs+ mimeRender _ = BSL.fromStrict instance ToJSON ByteString where toJSON x = object [ "val" .= x ]@@ -267,7 +259,7 @@ contentTypes _ = "text/plain" NE.:| [ "application/json" ] instance MimeRender JSONorText Int where- mimeRender _ = cs . show+ mimeRender _ = BSL8.pack . show instance MimeUnrender JSONorText Int where mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack@@ -279,6 +271,6 @@ addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)- where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)+ where new = BS8.pack (show $ contentType p) <> "; q=" <> BS8.pack (show f) cont "" = new- cont old = old `append` ", " `append` new+ cont old = old <> ", " <> new
test/Servant/API/ResponseHeadersSpec.hs view
@@ -2,10 +2,18 @@ {-# LANGUAGE OverloadedStrings #-} module Servant.API.ResponseHeadersSpec where +import Data.Proxy+import GHC.TypeLits import Test.Hspec +import Servant.API.ContentTypes+import Servant.API.Description+ (Description) import Servant.API.Header+import Servant.API.Modifiers+ (Optional, Strict) import Servant.API.ResponseHeaders+import Servant.API.UVerb spec :: Spec spec = describe "Servant.API.ResponseHeaders" $ do@@ -23,8 +31,19 @@ let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int getHeaders val `shouldBe` [("first", "10"), ("second", "b")] + it "adds a header with description to a value" $ do+ let val = addHeader' "hi" 5 :: Headers '[Header' '[Description "desc", Optional, Strict] "test" String] Int+ getHeaders val `shouldBe` [("test", "hi")]+ describe "noHeader" $ do it "does not add a header" $ do let val = noHeader 5 :: Headers '[Header "test" Int] Int getHeaders val `shouldBe` []++ describe "HasStatus Headers" $ do++ it "gets the status from the underlying value" $ do+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503+
test/Servant/LinksSpec.hs view
@@ -1,18 +1,26 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Servant.LinksSpec where +import GHC.Generics+ (Generic) import Data.Proxy (Proxy (..)) import Data.String (fromString)+import qualified Data.Text as T+import Network.URI+ (unEscapeString) import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Servant.API+import Servant.API.QueryString + (ToDeepQuery (toDeepQuery)) import Servant.Links import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)@@ -32,6 +40,9 @@ -- UVerb :<|> "uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent] + -- DeepQuery+ :<|> "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book]+ -- All of the verbs :<|> "get" :> Get '[JSON] NoContent :<|> "put" :> Put '[JSON] NoContent@@ -44,17 +55,67 @@ "all" :> CaptureAll "names" String :> Get '[JSON] NoContent :<|> "get" :> Get '[JSON] NoContent - apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint Link apiLink = safeLink (Proxy :: Proxy TestApi) +data Book+data BookQuery = BookQuery + { author :: String+ , year :: Int+ } deriving (Generic, Show, Eq)++instance ToDeepQuery BookQuery where+ toDeepQuery (BookQuery author year) =+ [ ([T.pack "author"], Just $ toQueryParam author)+ , ([T.pack "year"], Just $ toQueryParam year)+ ]+++newtype QuuxRoutes mode = QuuxRoutes+ { corge :: mode :- "corge" :> Post '[PlainText] NoContent+ } deriving Generic++newtype WaldoRoutes mode = WaldoRoutes+ { waldo :: mode :- "waldo" :> Get '[JSON] NoContent+ } deriving Generic++data FooRoutes mode = FooRoutes+ { baz :: mode :- "baz" :> Get '[JSON] NoContent+ , qux :: mode :- "qux" :> NamedRoutes QuuxRoutes+ , quux :: mode :- "quux" :> QueryParam "grault" String :> Get '[JSON] NoContent+ , garply :: mode :- "garply" :> Capture "garply" String+ :> Capture "garplyNum" Int :> NamedRoutes WaldoRoutes+ } deriving Generic++data BaseRoutes mode = BaseRoutes+ { foo :: mode :- "foo" :> NamedRoutes FooRoutes+ , bar :: mode :- "bar" :> Get '[JSON] NoContent+ } deriving Generic++recordApiLink+ :: (IsElem endpoint (NamedRoutes BaseRoutes), HasLink endpoint)+ => Proxy endpoint -> MkLink endpoint Link+recordApiLink = safeLink (Proxy :: Proxy (NamedRoutes BaseRoutes))+ -- | Convert a link to a URI and ensure that this maps to the given string -- given string shouldBeLink :: Link -> String -> Expectation shouldBeLink link expected = toUrlPiece link `shouldBe` fromString expected +shouldBeLinkUnescaped :: Link -> String -> Expectation+shouldBeLinkUnescaped link expected =+ unEscapeString (T.unpack $ toUrlPiece link) `shouldBe` fromString expected++(//) :: a -> (a -> b) -> b+x // f = f x+infixl 1 //++(/:) :: (a -> b -> c) -> b -> a -> c+(/:) = flip+infixl 2 /:+ spec :: Spec spec = describe "Servant.Links" $ do it "generates correct links for capture query params" $ do@@ -105,6 +166,38 @@ it "can generate all links for ComprehensiveAPIWithoutRaw" $ do let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw firstLink `shouldBeLink` ""++ it "Generate links from record fields accessors" $ do+ fieldLink bar `shouldBeLink` "bar"+ (fieldLink foo // baz) `shouldBeLink` "foo/baz"+ (fieldLink foo // qux // corge) `shouldBeLink` "foo/qux/corge"+ (fieldLink foo // quux /: Nothing) `shouldBeLink` "foo/quux"+ (fieldLink foo // quux /: Just "floop") `shouldBeLink` "foo/quux?grault=floop"+ (fieldLink foo // garply /: "captureme" /: 42 // waldo)+ `shouldBeLink` "foo/garply/captureme/42/waldo"++ it "generated correct links for DeepQuery" $ do+ let bFilter = Proxy :: Proxy ("books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book])+ let exampleQuery = BookQuery { author = "Herbert", year = 1965 }+ apiLink bFilter exampleQuery `shouldBeLinkUnescaped` "books?filter[author]=Herbert&filter[year]=1965"++ it "Check links from record fields" $ do+ let sub1 = Proxy :: Proxy ("bar" :> Get '[JSON] NoContent)+ recordApiLink sub1 `shouldBeLink` "bar"++ let sub2 = Proxy :: Proxy ("foo" :> "baz" :> Get '[JSON] NoContent)+ recordApiLink sub2 `shouldBeLink` "foo/baz"++ let sub3 = Proxy :: Proxy ("foo" :> "quux" :> QueryParam "grault" String+ :> Get '[JSON] NoContent)+ recordApiLink sub3 (Just "floop") `shouldBeLink` "foo/quux?grault=floop"++ let sub4 :: Proxy ("foo" :> "garply" :> Capture "garplyText" String+ :> Capture "garplyInt" Int :> "waldo"+ :> Get '[JSON] NoContent)+ sub4 = Proxy+ recordApiLink sub4 "captureme" 42+ `shouldBeLink` "foo/garply/captureme/42/waldo" -- The doctests below aren't run on CI, setting that up is tricky. -- They are run by makefile rule, however.