Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-servant for openSUSE:Factory checked in at 2025-06-04 20:29:46 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant (Old) and /work/SRC/openSUSE:Factory/.ghc-servant.new.16005 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-servant" Wed Jun 4 20:29:46 2025 rev:20 rq:1282757 version:0.20.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant/ghc-servant.changes 2025-04-03 16:51:13.458278105 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant.new.16005/ghc-servant.changes 2025-06-04 20:29:58.532518494 +0200 @@ -1,0 +2,45 @@ +Wed Jun 4 10:14:21 UTC 2025 - Peter Simons <[email protected]> + +- Update servant to version 0.20.3.0. + 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) + +------------------------------------------------------------------- Old: ---- servant-0.20.2.tar.gz servant.cabal New: ---- servant-0.20.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant.spec ++++++ --- /var/tmp/diff_new_pack.KCKJA9/_old 2025-06-04 20:29:59.200546194 +0200 +++ /var/tmp/diff_new_pack.KCKJA9/_new 2025-06-04 20:29:59.204546360 +0200 @@ -20,13 +20,12 @@ %global pkgver %{pkg_name}-%{version} %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.20.2 +Version: 0.20.3.0 Release: 0 Summary: A family of combinators for defining webservices APIs License: BSD-3-Clause URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz -Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal BuildRequires: ghc-Cabal-devel BuildRequires: ghc-QuickCheck-devel BuildRequires: ghc-QuickCheck-prof @@ -48,6 +47,8 @@ BuildRequires: ghc-containers-prof BuildRequires: ghc-deepseq-devel BuildRequires: ghc-deepseq-prof +BuildRequires: ghc-generics-sop-devel +BuildRequires: ghc-generics-sop-prof BuildRequires: ghc-http-api-data-devel BuildRequires: ghc-http-api-data-prof BuildRequires: ghc-http-media-devel @@ -114,7 +115,6 @@ %prep %autosetup -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal %build %ghc_lib_build ++++++ servant-0.20.2.tar.gz -> servant-0.20.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/CHANGELOG.md new/servant-0.20.3.0/CHANGELOG.md --- old/servant-0.20.2/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/servant.cabal new/servant-0.20.3.0/servant.cabal --- old/servant-0.20.2/servant.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/servant.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API/Alternative.hs new/servant-0.20.3.0/src/Servant/API/Alternative.hs --- old/servant-0.20.2/src/Servant/API/Alternative.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/src/Servant/API/Alternative.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API/ContentTypes.hs new/servant-0.20.3.0/src/Servant/API/ContentTypes.hs --- old/servant-0.20.2/src/Servant/API/ContentTypes.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/src/Servant/API/ContentTypes.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API/Host.hs new/servant-0.20.3.0/src/Servant/API/Host.hs --- old/servant-0.20.2/src/Servant/API/Host.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.20.3.0/src/Servant/API/Host.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API/MultiVerb.hs new/servant-0.20.3.0/src/Servant/API/MultiVerb.hs --- old/servant-0.20.2/src/Servant/API/MultiVerb.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.20.3.0/src/Servant/API/MultiVerb.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 {} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API/Range.hs new/servant-0.20.3.0/src/Servant/API/Range.hs --- old/servant-0.20.2/src/Servant/API/Range.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.20.3.0/src/Servant/API/Range.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API/ServerSentEvents.hs new/servant-0.20.3.0/src/Servant/API/ServerSentEvents.hs --- old/servant-0.20.2/src/Servant/API/ServerSentEvents.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.20.3.0/src/Servant/API/ServerSentEvents.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API/TypeLevel/List.hs new/servant-0.20.3.0/src/Servant/API/TypeLevel/List.hs --- old/servant-0.20.2/src/Servant/API/TypeLevel/List.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.20.3.0/src/Servant/API/TypeLevel/List.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/API.hs new/servant-0.20.3.0/src/Servant/API.hs --- old/servant-0.20.2/src/Servant/API.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/src/Servant/API.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/Links.hs new/servant-0.20.3.0/src/Servant/Links.hs --- old/servant-0.20.2/src/Servant/Links.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/src/Servant/Links.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/Types/Internal/Response.hs new/servant-0.20.3.0/src/Servant/Types/Internal/Response.hs --- old/servant-0.20.2/src/Servant/Types/Internal/Response.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-0.20.3.0/src/Servant/Types/Internal/Response.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/src/Servant/Types/SourceT.hs new/servant-0.20.3.0/src/Servant/Types/SourceT.hs --- old/servant-0.20.2/src/Servant/Types/SourceT.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/src/Servant/Types/SourceT.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 ------------------------------------------------------------------------------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.20.2/test/Servant/LinksSpec.hs new/servant-0.20.3.0/test/Servant/LinksSpec.hs --- old/servant-0.20.2/test/Servant/LinksSpec.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/servant-0.20.3.0/test/Servant/LinksSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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,6 +59,18 @@ => 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 @@ -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 // @@ -152,6 +176,11 @@ (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"
