packages feed

servant 0.20.2 → 0.20.3.0

raw patch · 14 files changed

+818/−12 lines, 14 filesdep +generics-sopdep ~QuickCheckdep ~aesondep ~basenew-uploader

Dependencies added: generics-sop

Dependency ranges changed: QuickCheck, aeson, base, bytestring, containers, http-api-data, network-uri

Files

CHANGELOG.md view
@@ -2,6 +2,47 @@  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)
servant.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               servant-version:            0.20.2+version:            0.20.3.0 synopsis:           A family of combinators for defining webservices APIs category:           Servant, Web description:@@ -20,8 +20,7 @@   2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors  build-type:         Simple-tested-with:-  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2 || ==9.10.1+tested-with:        GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1  extra-source-files: CHANGELOG.md @@ -58,7 +57,6 @@     RankNTypes     RecordWildCards     ScopedTypeVariables-    StrictData     TupleSections     TypeApplications     TypeFamilies@@ -91,22 +89,27 @@     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@@ -114,7 +117,9 @@     Servant.API.WithResource    -- Types-  exposed-modules: Servant.Types.SourceT+  exposed-modules:+    Servant.Types.SourceT+    Servant.Types.Internal.Response    -- Test stuff   exposed-modules: Servant.Test.ComprehensiveAPI@@ -127,12 +132,13 @@   --   -- note: mtl lower bound is so low because of GHC-7.8   build-depends:-    , base          >=4.14     && <4.21-    , bytestring    >=0.10.8.1 && <0.13+    , base          >= 4.16.4.0 && <4.22+    , bytestring    >=0.11 && <0.13     , constraints   >=0.2-    , containers    >=0.6      && <0.8+    , 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 @@ -178,6 +184,7 @@     , bytestring     , http-media     , mtl+    , network-uri     , servant     , text
src/Servant/API.hs view
@@ -14,6 +14,8 @@   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@@ -47,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, @@ -110,6 +115,7 @@                  ToServant, ToServantApi, fromServant, genericApi, toServant) import           Servant.API.Header                  (Header, Header')+import           Servant.API.Host (Host) import           Servant.API.HttpVersion                  (HttpVersion (..)) import           Servant.API.IsSecure@@ -134,6 +140,8 @@                  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,
src/Servant/API/Alternative.hs view
@@ -27,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@@ -35,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/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,6 +68,7 @@     , AllMimeUnrender(..)     , eitherDecodeLenient     , canHandleAcceptH+    , EventStreamChunk(..)     ) where  import           Control.Arrow@@ -102,6 +104,7 @@ data PlainText deriving Typeable data FormUrlEncoded deriving Typeable data OctetStream deriving Typeable+data EventStream deriving Typeable  -- * Accept class @@ -145,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) @@ -398,6 +405,12 @@ 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/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/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/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/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/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/Links.hs view
@@ -115,6 +115,7 @@   , linkSegments   , linkQueryParams   , linkFragment+  , addQueryParam ) where  import           Data.Kind@@ -161,6 +162,8 @@                  (NamedRoutes) import           Servant.API.QueryParam                  (QueryFlag, QueryParam', QueryParams)+import           Servant.API.QueryString+                 (ToDeepQuery, DeepQuery, generateDeepParam, toDeepQuery) import           Servant.API.Raw                  (Raw, RawM) import           Servant.API.RemoteHost@@ -183,10 +186,15 @@ import           Servant.API.WithResource                  (WithResource) import           Web.HttpApiData+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]@@ -198,7 +206,7 @@ type Fragment' = Maybe String  escaped :: String -> Escaped-escaped = Escaped . escapeURIString isUnreserved+escaped = Escaped . escape  getEscaped :: Escaped -> String getEscaped (Escaped s) = s@@ -232,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 } @@ -665,3 +681,31 @@                                          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/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
@@ -298,6 +298,22 @@     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 -------------------------------------------------------------------------------
test/Servant/LinksSpec.hs view
@@ -12,10 +12,15 @@                  (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)@@ -35,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@@ -51,7 +59,19 @@          => 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@@ -84,6 +104,10 @@ 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 //@@ -151,6 +175,11 @@       (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)