servant 0.15 → 0.20.3.0
raw patch · 47 files changed
Files
- CHANGELOG.md +486/−17
- Setup.hs +1/−32
- servant.cabal +121/−120
- src/Servant/API.hs +41/−7
- src/Servant/API/Alternative.hs +5/−11
- src/Servant/API/BasicAuth.hs +4/−2
- src/Servant/API/Capture.hs +4/−2
- src/Servant/API/ContentTypes.hs +39/−43
- src/Servant/API/Description.hs +5/−3
- src/Servant/API/Empty.hs +1/−4
- src/Servant/API/Experimental/Auth.hs +1/−1
- src/Servant/API/Fragment.hs +27/−0
- src/Servant/API/Generic.hs +4/−1
- src/Servant/API/Header.hs +3/−1
- src/Servant/API/Host.hs +13/−0
- src/Servant/API/Internal/Test/ComprehensiveAPI.hs +0/−6
- src/Servant/API/Modifiers.hs +6/−5
- src/Servant/API/MultiVerb.hs +500/−0
- src/Servant/API/NamedRoutes.hs +12/−0
- 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 +6/−2
- src/Servant/API/ReqBody.hs +3/−1
- src/Servant/API/ResponseHeaders.hs +87/−50
- src/Servant/API/ServerSentEvents.hs +37/−0
- src/Servant/API/Status.hs +160/−0
- src/Servant/API/Stream.hs +8/−8
- src/Servant/API/Sub.hs +3/−1
- src/Servant/API/TypeErrors.hs +59/−0
- src/Servant/API/TypeLevel.hs +76/−17
- src/Servant/API/TypeLevel/List.hs +14/−0
- src/Servant/API/UVerb.hs +128/−0
- src/Servant/API/UVerb/Union.hs +150/−0
- src/Servant/API/Verbs.hs +17/−8
- src/Servant/API/WithNamedContext.hs +3/−1
- src/Servant/API/WithResource.hs +3/−0
- src/Servant/Links.hs +176/−42
- src/Servant/Test/ComprehensiveAPI.hs +5/−2
- src/Servant/Types/Internal/Response.hs +17/−0
- src/Servant/Types/SourceT.hs +73/−23
- src/Servant/Utils/Links.hs +0/−6
- test/Servant/API/ContentTypesSpec.hs +43/−27
- test/Servant/API/ResponseHeadersSpec.hs +19/−0
- test/Servant/API/StreamSpec.hs +1/−1
- test/Servant/LinksSpec.hs +112/−2
- test/doctests.hs +0/−27
CHANGELOG.md view
@@ -1,5 +1,474 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.++0.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+------++Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).++0.19+----++### Significant changes++- Drop support for GHC < 8.6.+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)+ related to hash collisions.+- Add `NamedRoutes` combinator, making support for records first-class in Servant+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).+ + Users can now directly mark part as an API as defined by a record, instead of+ using `(:<|>)` to combine routes. Concretely, the anonymous:+ + ```haskell+ type API = + "version" :> Get '[JSON] String :<|>+ "products" :> Get '[JSON] [Product]+ ```+ + can be replaced with the explicitly-named:+ + ```haskell+ type API = NamedRoutes NamedAPI+ data NamedAPI mode = NamedAPI+ { version :: mode :- "version" :> Get '[JSON] String+ , products :: mode :- "products" :> Get '[JSON] [Product]+ }+ ```+ + `NamedRoutes` builds upon `servant-generic`, but improves usability by freeing+ users from the need to perform `toServant` / `fromServant` conversions+ manually. Serving `NamedRoutes NamedAPI` is now done directly by providing a+ record of handlers, and servant generates clients directly as records as well.+ In particular, it makes it much more practical to work with nested hierarchies+ of named routes.++ Two convenience functions, `(//)` and `(/:)`, have been added to make the+ usage of named route hierarchies more pleasant:+ + ```haskell+ rootClient :: RootApi (AsClientT ClientM)+ rootClient = client (Proxy @API)++ helloClient :: String -> ClientM String+ helloClient name = rootClient // hello /: name++ endpointClient :: ClientM Person+ endpointClient = rootClient // subApi /: "foobar123" // endpoint++ type Api = NamedRoutes RootApi++ data RootApi mode = RootApi+ { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi+ , hello :: mode :- Capture "name" String :> Get '[JSON] String+ , …+ } deriving Generic++ data SubApi mode = SubApi+ { endpoint :: mode :- Get '[JSON] Person+ , …+ } deriving Generic+ ```+ +- Add custom type errors for partially applied combinators+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).+ + For example, forgetting to document the expected type for a query parameter,+ as in:+ + ``` haskell+ type API = QueryParam "param" :> Get '[JSON] NoContent+ ```+ + will raise to the following error when trying to serve the API:++ ```+ • There is no instance for HasServer (QueryParam'+ '[Optional, Strict] "param" :> ...)+ QueryParam' '[Optional, Strict] "1" expects 1 more arguments+ ```+ + As a consequence of this change, unsaturated types are now forbidden before `(:>)`.+ +- Add a `HeadNoContent` verb ([#1502](https://github.com/haskell-servant/servant/pull/1502)).++- *servant-client* / *servant-client-core* / *servant-http-streams*:+ Fix erroneous behavior, where only 2XX status codes would be considered+ successful, irrelevant of the status parameter specified by the verb+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))++- *servant-client* / *servant-client-core*: Fix `Show` instance for+ `Servant.Client.Core.Request`.+ + +- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data+ in Query parameters.+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).++- *servant-docs*: Generate sample cURL requests+ ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).++ Breaking change: requires sample header values to be supplied with `headers`.+ +### Other changes++- Various bit rotten cookbooks have been updated and re-introduced on+ [docs.servant.dev](https://docs.servant.dev).++- Various version bumps.++0.18.3+------++### Significant changes++- Add response header support to UVerb (#1420).+- Use Capture Description if available (#1423).++### Other changes++- Support GHC-9.0.1.+- Bump `bytestring`, `attoparsec`, `hspec` and `singleton-bool` dependencies.++0.18.2+------++### Significant changes++- Introduce `Fragment` combinator.+- Fix `MimeRender` and `MimeUnrender` instances for `WithStatus`.++0.18.1+------++### Significant changes++- Union verbs++### Other changes++- Bump "tested-with" ghc versions+- Allow newer dependencies++0.18+----++### Significant changes++- Support for ghc8.8 (#1318, #1326, #1327)++- Configurable error messages for automatic errors thrown by servant,+ like "no route" or "could not parse json body" (#1312, #1326, #1327)++### Other changes++- Witness that a type-level natural number corresponds to a HTTP+ status code (#1310)++- Improve haddocs (#1279)++- Dependency management (#1269, #1293, #1286, #1287)+++0.17+----++### Significant changes++- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)++ The `NoContent` API endpoints should now use `NoContentVerb` combinator.+ The API type changes are usually of the kind++ ```diff+ - :<|> PostNoContent '[JSON] NoContent+ + :<|> PostNoContent+ ```++ i.e. one doesn't need to specify the content-type anymore. There is no content.++- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)++ You can specify a lenient capture as++ ```haskell+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET+ ```++ which will make the capture always succeed. Handlers will be of the+ type `Either String CapturedType`, where `Left err` represents+ the possible parse failure.++- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255)++ The new member `makeClientRequest` of `ClientEnv` is used to create+ `http-client` `Request` from `servant-client-core` `Request`.+ This functionality can be used for example to set+ dynamic timeouts for each request.++- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262)++ Some APIs need query parameters rewriting, e.g. in order to support+ for multiple casing (camel, snake, etc) or something to that effect.++ This could be easily achieved by using WAI Middleware and modifying+ request's `Query`. But QueryParam, QueryParams and QueryFlag use+ `rawQueryString`. By using `queryString` rather then `rawQueryString`+ we can enable such rewritings.++- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263)++ We used `build-type: Custom`, but it's problematic e.g.+ for cross-compiling. The benefit is small, as the doctests+ can be run other ways too (though not so conveniently).++- *servant* Remove deprecated modules [1268#](https://github.com/haskell-servant/servant/pull/1268)++ - `Servant.Utils.Links` is `Servant.Links`+ - `Servant.API.Internal.Test.ComprehensiveAPI` is `Servant.Test.ComprehensiveAPI`++### Other changes++- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)++ For `Verb`s with response `Headers`, the implementation didn't check+ for the content-type of the response. Now it does.++- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241)++ Servant supports defining the same route multiple times with different+ content-types and result-types, but servant-docs was only documenting+ the first of copy of such duplicated routes. It now combines the+ documentation from all the copies.++ Unfortunately, it is not yet possible for the documentation to specify+ multiple status codes.++- Add sponsorship button [#1190](https://github.com/haskell-servant/servant/pull/1190)++ [Well-Typed](https://www.well-typed.com/) is a consultancy which could help you with `servant` issues+ (See consultancies section on https://www.servant.dev/).++- Try changelog-d for changelog management [#1230](https://github.com/haskell-servant/servant/pull/1230)++ Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details++- CI and testing tweaks. [#1154](https://github.com/haskell-servant/servant/pull/1154) [#1157](https://github.com/haskell-servant/servant/pull/1157) [#1182](https://github.com/haskell-servant/servant/pull/1182) [#1214](https://github.com/haskell-servant/servant/pull/1214) [#1229](https://github.com/haskell-servant/servant/pull/1229) [#1233](https://github.com/haskell-servant/servant/pull/1233) [#1242](https://github.com/haskell-servant/servant/pull/1242) [#1247](https://github.com/haskell-servant/servant/pull/1247) [#1250](https://github.com/haskell-servant/servant/pull/1250) [#1258](https://github.com/haskell-servant/servant/pull/1258)++ We are experiencing some bitrotting of cookbook recipe dependencies,+ therefore some of them aren't build as part of our CI anymore.++- New cookbook recipes [#1088](https://github.com/haskell-servant/servant/pull/1088) [#1171](https://github.com/haskell-servant/servant/pull/1171) [#1198](https://github.com/haskell-servant/servant/pull/1198)++ - [OIDC Recipe](#TODO)+ - [MySQL Recipe](#TODO)++- *servant-jsaddle* Progress on servant-jsaddle [#1216](https://github.com/haskell-servant/servant/pull/1216)+- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194)+- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)+- *servant* Remove unused extensions from cabal file [#1201](https://github.com/haskell-servant/servant/pull/1201)+- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)+- Dependency upgrades [#1173](https://github.com/haskell-servant/servant/pull/1173) [#1181](https://github.com/haskell-servant/servant/pull/1181) [#1183](https://github.com/haskell-servant/servant/pull/1183) [#1188](https://github.com/haskell-servant/servant/pull/1188) [#1224](https://github.com/haskell-servant/servant/pull/1224) [#1245](https://github.com/haskell-servant/servant/pull/1245) [#1257](https://github.com/haskell-servant/servant/pull/1257)+- Documentation updates [#1162](https://github.com/haskell-servant/servant/pull/1162) [#1174](https://github.com/haskell-servant/servant/pull/1174) [#1175](https://github.com/haskell-servant/servant/pull/1175) [#1234](https://github.com/haskell-servant/servant/pull/1234) [#1244](https://github.com/haskell-servant/servant/pull/1244) [#1247](https://github.com/haskell-servant/servant/pull/1247)+++0.16.2+------++* `singleton-bool-0.1.5` (`SBool` is re-exported)+ - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+)+ - Add `Show`, `Eq`, `Ord` `SBool b` instances.+* dependencies update++0.16.1+------++* Add `Semigroup` and `Monoid` `SourceT` instances+ [#1158](https://github.com/haskell-servant/servant/pull/1158)+ [#1159](https://github.com/haskell-servant/servant/pull/1159)+* Use `http-api-data-0.4.1`+ [#1181](https://github.com/haskell-servant/servant/pull/1181)+* Allow newer dependencies++0.16.0.1+--------++- Make tests work with `http-media-0.8`++0.16+----++### Significant changes++- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`+ [#1131](https://github.com/haskell-servant/servant/pull/1131)+- *servant-client-core* Rearrange modules. No more `Internal` modules, whole+ API is versioned.+ [#1130](https://github.com/haskell-servant/servant/pull/1130)+- *servant-http-streams* New package+ [#1117](https://github.com/haskell-servant/servant/pull/1117)+- *servant-client-core* `RequestBody` is now++ ```haskell+ = RequestBodyLBS LBS.ByteString+ | RequestBodyBS BS.ByteString+ | RequestBodySource (SourceIO LBS.ByteString)+ ```++ i.e. no more replicates `http-client`s API.+ [#1117](https://github.com/haskell-servant/servant/pull/1117)++- *servant-client-core* Keep structured exceptions in `ConnectionError`+ constructor of `ClientError`+ [#1115](https://github.com/haskell-servant/servant/pull/1115)++ ```diff+ -| ConnectionError Text+ +| ConnectionError SomeException+ ```++- *servant-client-core* Preserve failing request in `FailureResponse`+ constructor of `ClientError`+ [#1114](https://github.com/haskell-servant/servant/pull/1114)++ ```diff+ -FailureResponse Response+ +-- | The server returned an error response including the+ +-- failing request. 'requestPath' includes the 'BaseUrl' and the+ +-- path of the request.+ +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response+ ```++- *servant-client* Fix (implement) `StreamBody` instance+ [#1110](https://github.com/haskell-servant/servant/pull/1110)++### Other changes++- *servant-client* Update CookieJar with intermediate request/responses (redirects)+ [#1104](https://github.com/haskell-servant/servant/pull/1104)+- *servant-server* Reorder HTTP failure code priorities+ [#1103](https://github.com/haskell-servant/servant/pull/1103)+- *servant-server* Re-organise internal modules+ [#1139](https://github.com/haskell-servant/servant/pull/1139)+- Allow `network-3.0`+ [#1107](https://github.com/haskell-servant/servant/pull/1107)+- Add `NFData NoContent` instance+ [#1090](https://github.com/haskell-servant/servant/pull/1090)++- Documentation updates+ [#1127](https://github.com/haskell-servant/servant/pull/1127)+ [#1124](https://github.com/haskell-servant/servant/pull/1124)+ [#1098](https://github.com/haskell-servant/servant/pull/1098)++- CI updates+ [#1123](https://github.com/haskell-servant/servant/pull/1123)+ [#1121](https://github.com/haskell-servant/servant/pull/1121)+ [#1119](https://github.com/haskell-servant/servant/pull/1119)+ 0.15 ---- @@ -133,18 +602,18 @@ [#985](https://github.com/haskell-servant/servant/pull/985) - *Documentation* Tutorial and new recipes- - [Using free client](https://haskell-servant.readthedocs.io/en/latest/cookbook/using-free-client/UsingFreeClient.html)+ - [Using free client](https://docs.servant.dev/en/latest/cookbook/using-free-client/UsingFreeClient.html) [#1005](https://github.com/haskell-servant/servant/pull/1005)- - [Generating mock curl calls](https://haskell-servant.readthedocs.io/en/latest/cookbook/curl-mock/CurlMock.html)+ - [Generating mock curl calls](https://docs.servant.dev/en/latest/cookbook/curl-mock/CurlMock.html) [#1033](https://github.com/haskell-servant/servant/pull/1033)- - [Error logging with Sentry](https://haskell-servant.readthedocs.io/en/latest/cookbook/sentry/Sentry.html)+ - [Error logging with Sentry](https://docs.servant.dev/en/latest/cookbook/sentry/Sentry.html) [#987](https://github.com/haskell-servant/servant/pull/987)- - [Hoist Server With Context for Custom Monads](https://haskell-servant.readthedocs.io/en/latest/cookbook/hoist-server-with-context/HoistServerWithContext.html)+ - [Hoist Server With Context for Custom Monads](https://docs.servant.dev/en/latest/cookbook/hoist-server-with-context/HoistServerWithContext.html) [#1044](https://github.com/haskell-servant/servant/pull/1044)- - [How To Test Servant Applications](https://haskell-servant.readthedocs.io/en/latest/cookbook/testing/Testing.html)+ - [How To Test Servant Applications](https://docs.servant.dev/en/latest/cookbook/testing/Testing.html) [#1050](https://github.com/haskell-servant/servant/pull/1050) - `genericServeT`: using custom monad with `Servant.API.Generic`- in [Using generics](https://haskell-servant.readthedocs.io/en/latest/cookbook/generic/Generic.html)+ in [Using generics](https://docs.servant.dev/en/latest/cookbook/generic/Generic.html) [#1058](https://github.com/haskell-servant/servant/pull/1058) - Tutorial [#974](https://github.com/haskell-servant/servant/pull/974)@@ -177,7 +646,7 @@ 0.14 ---- -### Signifacant changes+### Significant changes - `Stream` takes a status code argument @@ -210,9 +679,9 @@ - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers- of a web application live in, we also have `hoistClient` for changing the monad+ of a web application live, we also have `hoistClient` for changing the monad in which *client functions* live.- Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).+ Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) iF you have own combinators, you'll need to define a new method of@@ -259,10 +728,10 @@ - Added tests or enabled tests ([#975](https://github.com/haskell-servant/servant/pull/975)) -- Add [pagination cookbook recipe](https://haskell-servant.readthedocs.io/en/release-0.14/cookbook/pagination/Pagination.html)+- Add [pagination cookbook recipe](https://docs.servant.dev/en/release-0.14/cookbook/pagination/Pagination.html) ([#946](https://github.com/haskell-servant/servant/pull/946)) -- Add [`servant-flatten` "spice" to the structuring api recipe](https://haskell-servant.readthedocs.io/en/release-0.14/cookbook/structuring-apis/StructuringApis.html)+- Add [`servant-flatten` "spice" to the structuring api recipe](https://docs.servant.dev/en/release-0.14/cookbook/structuring-apis/StructuringApis.html) ([#929](https://github.com/haskell-servant/servant/pull/929)) - Dependency updates@@ -292,7 +761,7 @@ ### Note -(VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant/pull\/\1)/`+(VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant\/pull\/\1)/` 0.13.0.1 --------@@ -312,9 +781,9 @@ ``` See tutorial for more details- - [A web API as a type - StreamGet and StreamPost](http://haskell-servant.readthedocs.io/en/release-0.13/tutorial/ApiType.html#streamget-and-streampost)- - [Serving an API - streaming endpoints](http://haskell-servant.readthedocs.io/en/release-0.13/tutorial/Server.html#streaming-endpoints)- - [Querying an API - Querying Streaming APIs](http://haskell-servant.readthedocs.io/en/release-0.13/tutorial/Client.html#querying-streaming-apis)+ - [A web API as a type - StreamGet and StreamPost](http://docs.servant.dev/en/release-0.13/tutorial/ApiType.html#streamget-and-streampost)+ - [Serving an API - streaming endpoints](http://docs.servant.dev/en/release-0.13/tutorial/Server.html#streaming-endpoints)+ - [Querying an API - Querying Streaming APIs](http://docs.servant.dev/en/release-0.13/tutorial/Client.html#querying-streaming-apis) - *servant* Add `Servant.API.Modifiers` ([#873](https://github.com/haskell-servant/servant/pull/873)@@ -345,7 +814,7 @@ ([#893](https://github.com/haskell-servant/servant/pull/893)) - *Cookbook* example projects at- http://haskell-servant.readthedocs.io/en/master/cookbook/index.html+ http://docs.servant.dev/en/master/cookbook/index.html ([#867](https://github.com/haskell-servant/servant/pull/867) [#892](https://github.com/haskell-servant/servant/pull/882)) @@ -417,7 +886,7 @@ `enter` isn't exported from `Servant` module anymore. You can change `enter` to `hoistServer` in a straight forward way.- Unwrap natural transformation and add a api type `Proxy`:+ Unwrap natural transformation and add an api type `Proxy`: ```diff -server = enter (NT nt) impl
Setup.hs view
@@ -1,33 +1,2 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif--#if MIN_VERSION_cabal_doctest(1,0,0)--import Distribution.Extra.Doctest ( defaultMainWithDoctests )-main :: IO ()-main = defaultMainWithDoctests "doctests"--#else--#ifdef MIN_VERSION_Cabal--- If the macro is defined, we have new cabal-install,--- but for some reason we don't have cabal-doctest in package-db------ Probably we are running cabal sdist, when otherwise using new-build--- workflow-#warning You are configuring this package without cabal-doctest installed. \- The doctests test-suite will not work as a result. \- To fix this, install cabal-doctest before configuring.-#endif--import Distribution.Simple--main :: IO ()+import Distribution.Simple main = defaultMain--#endif
servant.cabal view
@@ -1,45 +1,82 @@-cabal-version: >=1.10-name: servant-version: 0.15--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 .- You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.+ You can learn about the basics in the <http://docs.servant.dev/en/stable/tutorial/index.html tutorial>. . <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG> -homepage: http://haskell-servant.readthedocs.org/-bug-reports: http://github.com/haskell-servant/servant/issues-license: BSD3-license-file: LICENSE-author: Servant Contributors-maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors-build-type: Custom+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.0.2- || ==8.2.2- || ==8.4.4- || ==8.6.2+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 -custom-setup- setup-depends:- base >= 4 && <5,- Cabal,- cabal-doctest >= 1.0.6 && <1.1+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@@ -49,148 +86,112 @@ Servant.API.Description Servant.API.Empty Servant.API.Experimental.Auth+ 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-- -- Deprecated modules, to be removed in late 2019- exposed-modules:- Servant.Utils.Links- Servant.API.Internal.Test.ComprehensiveAPI+ 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.13- , bytestring >= 0.10.8.1 && < 0.11- , mtl >= 2.2.2 && < 2.3- , transformers >= 0.5.2.0 && < 0.6- , text >= 1.2.3.0 && < 1.3-+ , 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 && < 0.4.1- , singleton-bool >= 0.1.4 && < 0.1.5+ , 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.11- , aeson >= 1.4.1.0 && < 1.5- , attoparsec >= 0.13.2.2 && < 0.14- , bifunctors >= 5.5.3 && < 5.6- , case-insensitive >= 1.2.0.11 && < 1.3- , http-media >= 0.7.1.3 && < 0.8- , http-types >= 0.12.2 && < 0.13- , mmorph >= 1.1.2 && < 1.2- , network-uri >= 2.6.1.0 && < 2.7- , QuickCheck >= 2.12.6.1 && <2.13- , string-conversions >= 0.4.0.1 && < 0.5- , tagged >= 0.8.6 && < 0.9- , vault >= 0.3.1.2 && < 0.4+ , 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 - hs-source-dirs: src- default-language: Haskell2010- other-extensions: CPP- , ConstraintKinds- , DataKinds- , DeriveDataTypeable- , FlexibleInstances- , FunctionalDependencies- , GADTs- , KindSignatures- , MultiParamTypeClasses- , OverlappingInstances- , OverloadedStrings- , PolyKinds- , QuasiQuotes- , RecordWildCards- , ScopedTypeVariables- , TemplateHaskell- , TypeFamilies- , TypeOperators- , TypeSynonymInstances- , UndecidableInstances- 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 - -- Additonal dependencies- build-depends:- hspec >= 2.6.0 && < 2.7- , QuickCheck >= 2.12.6.1 && < 2.13- , quickcheck-instances >= 0.3.19 && < 0.4-- build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && < 2.7--test-suite doctests- build-depends:- base- , servant- , doctest >= 0.16.0 && <0.17-- -- We test Links failure with doctest, so we need extra dependencies+ -- Additional dependencies build-depends:- hspec >= 2.6.0 && < 2.7+ , hspec >=2.6.0 && <2.12+ , QuickCheck >=2.12.6.1 && <2.16+ , quickcheck-instances >=0.3.19 && <0.4 - type: exitcode-stdio-1.0- main-is: test/doctests.hs- buildable: True- default-language: Haskell2010- ghc-options: -Wall -threaded- if impl(ghc >= 8.2)- x-doctest-options: -fdiagnostics-color=never- x-doctest-source-dirs: test- x-doctest-modules: Servant.LinksSpec+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12
src/Servant/API.hs view
@@ -14,11 +14,17 @@ 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, -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ module Servant.API.RemoteHost,@@ -29,13 +35,23 @@ -- | 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,+ module Servant.API.UVerb, + -- * Sub-APIs defined as records of routes+ module Servant.API.NamedRoutes,+ module Servant.API.Generic,+ -- * Streaming endpoints, distinguished by HTTP method module Servant.API.Stream, + -- * Server-sent events (SSE)+ module Servant.API.ServerSentEvents,+ -- * Authentication module Servant.API.BasicAuth, @@ -92,18 +108,28 @@ (EmptyAPI (..)) import Servant.API.Experimental.Auth (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.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@@ -111,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,@@ -120,19 +149,24 @@ ToSourceIO (..)) import Servant.API.Sub ((:>))+import Servant.API.UVerb+ (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union,+ Unique, WithStatus (..), inject, statusOf) import Servant.API.Vault (Vault) import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, GetNonAuthoritative, GetPartialContent, GetResetContent,- Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative,- Post, PostAccepted, PostCreated, PostNoContent,- PostNonAuthoritative, PostResetContent, Put, PutAccepted,- PutCreated, PutNoContent, PutNonAuthoritative,+ NoContentVerb, Patch, PatchAccepted, PatchNoContent,+ PatchNonAuthoritative, Post, PostAccepted, PostCreated,+ PostNoContent, PostNonAuthoritative, PostResetContent, Put,+ PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative, 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@@ -16,12 +15,8 @@ (Bifunctor (..)) import Data.Bitraversable (Bitraversable (..))-import Data.Semigroup- (Semigroup (..)) import Data.Typeable (Typeable)-import Prelude ()-import Prelude.Compat -- | Union of two APIs, first takes precedence in case of overlap. --@@ -32,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@@ -40,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
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -20,10 +21,10 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: ----- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book+-- >>> 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,@@ -48,6 +49,7 @@ , PlainText , FormUrlEncoded , OctetStream+ , EventStream -- * Building your own Content-Type , Accept(..)@@ -66,28 +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@@ -97,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) @@ -107,6 +104,7 @@ data PlainText deriving Typeable data FormUrlEncoded deriving Typeable data OctetStream deriving Typeable+data EventStream deriving Typeable -- * Accept class @@ -150,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) @@ -173,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).@@ -227,7 +229,7 @@ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} -class AllCTUnrender (list :: [*]) a where+class AllCTUnrender (list :: [Type]) a where canHandleCTypeH :: Proxy list -> ByteString -- Content-Type header@@ -241,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@@ -264,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@@ -292,19 +294,19 @@ -- then this would be taken care of. However there is no more specific instance -- between that and 'MimeRender JSON a', so we do this instead instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where- allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp where pctyp = Proxy :: Proxy ctyp 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)] @@ -347,7 +349,7 @@ -- | @BC.pack@ instance MimeRender PlainText String where- mimeRender _ = BC.pack+ mimeRender _ = TextL.encodeUtf8 . TextL.pack -- | @id@ instance MimeRender OctetStream ByteString where@@ -361,32 +363,21 @@ data NoContent = NoContent deriving (Show, Eq, Read, Generic) +instance NFData NoContent + -------------------------------------------------------------------------- -- * 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@@ -404,17 +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@@ -39,14 +41,14 @@ --type MyApi = Description -- "This comment is visible in multiple Servant interpretations \ -- \and can be really long if necessary. \--- \Haskell multiline support is not perfect \+-- \Haskell multiline String support is not perfect \ -- \but it's still very readable." -- :> Get '[JSON] Book -- :} data Description (sym :: Symbol) deriving (Typeable) --- | Fold modifier list to decide whether argument should be parsed strictly or leniently.+-- | Fold list of modifiers to extract description as a type-level String. -- -- >>> :kind! FoldDescription '[] -- FoldDescription '[] :: Symbol@@ -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
@@ -0,0 +1,27 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}++{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Fragment (Fragment) where++import Data.Kind+ (Type)+import Data.Typeable+ (Typeable)++-- | Document the URI fragment in API. Useful in combination with 'Link'.+--+-- Example:+--+-- >>> -- /post#TRACKING+-- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking+data Fragment (a :: Type)+ deriving Typeable++-- $setup+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Tracking+-- >>> instance ToJSON Tracking where { toJSON = undefined }
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/Internal/Test/ComprehensiveAPI.hs
@@ -1,6 +0,0 @@-module Servant.API.Internal.Test.ComprehensiveAPI- {-# DEPRECATED "Use Servant.TestComprehensiveAPI" #-}- ( module Servant.Test.ComprehensiveAPI )- where--import Servant.Test.ComprehensiveAPI
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@@ -130,8 +133,6 @@ If (FoldRequired mods) (If (FoldLenient mods) (Either Text a) a) (Maybe (If (FoldLenient mods) (Either Text a) a))-- -- | Unfold a value into a 'RequestArgument'. unfoldRequestArgument
+ 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
@@ -0,0 +1,12 @@+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_HADDOCK not-home #-}++module Servant.API.NamedRoutes (+ -- * NamedRoutes combinator+ NamedRoutes+ ) where++import Data.Kind (Type)++-- | Combinator for embedding a record of named routes into a Servant API type.+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
@@ -11,6 +11,10 @@ -- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's,--- this can also be used with <https://hackage.haskell.org/package/servant-server/docs/Servant-Utils-StaticFiles.html#v:serveDirectory serveDirectory> to serve--- static files stored in a particular directory on your filesystem+-- this can also be used with functions from+-- <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,18 +1,5 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# 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. --@@ -25,7 +12,9 @@ , ResponseHeader (..) , AddHeader , addHeader+ , addHeader' , noHeader+ , noHeader' , HasResponseHeader , lookupResponseHeader , BuildHeadersTo(buildHeadersTo)@@ -35,9 +24,14 @@ , HList(..) ) where +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'.@@ -60,43 +57,56 @@ -- ^ HList of headers. } deriving (Functor) +instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where+ rnf (Headers x hdrs) = rnf x `seq` rnf hdrs+ data ResponseHeader (sym :: Symbol) a = Header a | MissingHeader | UndecodableHeader ByteString deriving (Typeable, Eq, Show, Functor) +instance NFData a => NFData (ResponseHeader sym a) where+ rnf MissingHeader = ()+ rnf (UndecodableHeader bs) = rnf bs+ rnf (Header x) = rnf x+ 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) -type family HeaderValMap (f :: * -> *) (xs :: [*]) where+class NFDataHList xs where rnfHList :: HList xs -> ()+instance NFDataHList '[] where rnfHList HNil = ()+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 :: 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 occurences 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+-- * Getting headers class GetHeaders ls where getHeaders :: ls -> [HTTP.Header]@@ -112,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@@ -133,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+-- * 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) -instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v- , new ~ (Headers '[Header h v] a) )- => AddHeader h v a new where+-- In this instance, 'a' parameter is decorated with a Header.+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@@ -174,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/Status.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DataKinds #-}+-- Flexible instances is necessary on GHC 8.4 and earlier+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Servant.API.Status where++import GHC.TypeLits (KnownNat, natVal)+import Network.HTTP.Types.Status++-- | Retrieve a known or unknown Status from a KnownNat+statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status+statusFromNat = toEnum . fromInteger . natVal++-- | Witness that a type-level natural number corresponds to a HTTP status code+class KnownNat n => KnownStatus n where+ statusVal :: proxy n -> Status++instance KnownStatus 100 where+ statusVal _ = status100++instance KnownStatus 101 where+ statusVal _ = status101++instance KnownStatus 200 where+ statusVal _ = status200++instance KnownStatus 201 where+ statusVal _ = status201++instance KnownStatus 202 where+ statusVal _ = status202++instance KnownStatus 203 where+ statusVal _ = status203++instance KnownStatus 204 where+ statusVal _ = status204++instance KnownStatus 205 where+ statusVal _ = status205++instance KnownStatus 206 where+ statusVal _ = status206++instance KnownStatus 300 where+ statusVal _ = status300++instance KnownStatus 301 where+ statusVal _ = status301++instance KnownStatus 302 where+ statusVal _ = status302++instance KnownStatus 303 where+ statusVal _ = status303++instance KnownStatus 304 where+ statusVal _ = status304++instance KnownStatus 305 where+ statusVal _ = status305++instance KnownStatus 307 where+ statusVal _ = status307++instance KnownStatus 308 where+ statusVal _ = status308++instance KnownStatus 400 where+ statusVal _ = status400++instance KnownStatus 401 where+ statusVal _ = status401++instance KnownStatus 402 where+ statusVal _ = status402++instance KnownStatus 403 where+ statusVal _ = status403++instance KnownStatus 404 where+ statusVal _ = status404++instance KnownStatus 405 where+ statusVal _ = status405++instance KnownStatus 406 where+ statusVal _ = status406++instance KnownStatus 407 where+ statusVal _ = status407++instance KnownStatus 408 where+ statusVal _ = status408++instance KnownStatus 409 where+ statusVal _ = status409++instance KnownStatus 410 where+ statusVal _ = status410++instance KnownStatus 411 where+ statusVal _ = status411++instance KnownStatus 412 where+ statusVal _ = status412++instance KnownStatus 413 where+ statusVal _ = status413++instance KnownStatus 414 where+ statusVal _ = status414++instance KnownStatus 415 where+ statusVal _ = status415++instance KnownStatus 416 where+ statusVal _ = status416++instance KnownStatus 417 where+ statusVal _ = status417++instance KnownStatus 418 where+ statusVal _ = status418++instance KnownStatus 422 where+ statusVal _ = status422++instance KnownStatus 426 where+ statusVal _ = status426++instance KnownStatus 428 where+ statusVal _ = status428++instance KnownStatus 429 where+ statusVal _ = status429++instance KnownStatus 431 where+ statusVal _ = status431++instance KnownStatus 500 where+ statusVal _ = status500++instance KnownStatus 501 where+ statusVal _ = status501++instance KnownStatus 502 where+ statusVal _ = status502++instance KnownStatus 503 where+ statusVal _ = status503++instance KnownStatus 504 where+ statusVal _ = status504++instance KnownStatus 505 where+ statusVal _ = status505++instance KnownStatus 511 where+ statusVal _ = status511
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,10 +45,10 @@ 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.Monoid- ((<>)) import Data.Proxy (Proxy) import Data.Typeable@@ -65,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@@ -74,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) -------------------------------------------------------------------------------@@ -115,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
@@ -0,0 +1,59 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module defines the error messages used in type-level errors.+-- Type-level errors can signal non-existing instances, for instance when+-- a combinator is not applied to the correct number of arguments.++module Servant.API.TypeErrors (+ PartialApplication,+ NoInstanceFor,+ NoInstanceForSub,+ ErrorIfNoGeneric,+) where++import Data.Kind (Type, Constraint)+import GHC.Generics (Generic(..))+import GHC.TypeLits++-- | No instance exists for @tycls (expr :> ...)@ because +-- @expr@ is not recognised.+type NoInstanceForSub (tycls :: k) (expr :: k') =+ Text "There is no instance for " :<>: ShowType tycls+ :<>: Text " (" :<>: ShowType expr :<>: Text " :> ...)"++-- | No instance exists for @expr@.+type NoInstanceFor (expr :: k) =+ Text "There is no instance for " :<>: ShowType expr++-- | No instance exists for @tycls (expr :> ...)@ because @expr@ is not fully saturated.+type PartialApplication (tycls :: k) (expr :: k') =+ NoInstanceForSub tycls expr+ :$$: ShowType expr :<>: Text " expects " :<>: ShowType (Arity expr) :<>: Text " more arguments"++-- The arity of a combinator, i.e. the number of required arguments.+type Arity (ty :: k) = Arity' k++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
@@ -1,13 +1,17 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+ {-| This module collects utilities for manipulating @servant@ API types. The functionality in this module is for advanced usage.@@ -41,25 +45,37 @@ -- ** Logic Or, And,+ -- ** Fragment+ FragmentUnique,+ 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 (Verb)+import Servant.API.UVerb+ (UVerb) import GHC.TypeLits (ErrorMessage (..), TypeError) @@ -100,7 +116,7 @@ -- -- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI)) -- ...--- ... Could not deduce...+-- ... Could not ... -- ... -- -- An endpoint is considered within an api even if it is missing combinators@@ -120,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@@ -128,9 +145,11 @@ IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb+ IsElem sa (Fragment x :> sb) = IsElem sa sb 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@.@@ -140,7 +159,7 @@ -- -- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI)) -- ...--- ... Could not deduce...+-- ... Could not ... -- ... -- -- This uses @IsElem@ for checking; thus the note there applies here.@@ -163,12 +182,13 @@ -- -- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))) -- ...--- ... Could not deduce...+-- ... 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@. --@@ -178,7 +198,7 @@ -- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@). ----- ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI))+-- >>> ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI)) -- OK type family AllIsIn xs api :: Constraint where AllIsIn '[] api = ()@@ -224,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 () () = () @@ -241,13 +261,51 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -} +-- ** Fragment +-- | 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 AtMostOneFragment FailAPI+-- ...+-- ...Only one Fragment allowed per endpoint in api...+-- ...+class FragmentUnique api => AtMostOneFragment api++instance AtMostOneFragment (Verb m s ct typ)++instance AtMostOneFragment (UVerb m cts as)++instance AtMostOneFragment (Fragment a)++type family FragmentUnique api :: Constraint where+ FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb)+ FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa)+ FragmentUnique (x :> sa) = FragmentUnique sa+ FragmentUnique (Fragment a) = ()+ FragmentUnique x = ()++type family FragmentNotIn api orig :: Constraint where+ FragmentNotIn (sa :<|> sb) orig =+ And (FragmentNotIn sa orig) (FragmentNotIn sb orig)+ FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig)+ FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig+ FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig)+ FragmentNotIn x orig = ()++type NotUniqueFragmentInApi api =+ 'Text "Only one Fragment allowed per endpoint in api ‘"+ ':<>: 'ShowType api+ ':<>: 'Text "’."+ -- $setup -- -- The doctests in this module are run with following preamble: -- -- >>> :set -XPolyKinds -- >>> :set -XGADTs+-- >>> :set -XTypeSynonymInstances -XFlexibleInstances -- >>> import Data.Proxy -- >>> import Data.Type.Equality -- >>> import Servant.API@@ -255,4 +313,5 @@ -- >>> instance Show (OK ctx) where show _ = "OK" -- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK -- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool+-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent -- >>> let sampleAPI = Proxy :: Proxy SampleAPI
+ 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
@@ -0,0 +1,128 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+++-- | 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`)+--+-- This can be used for returning (rather than throwing) exceptions in a server as in, say+-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or+-- 201 created with a different body type, depending on the circumstances. (All of this can+-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in+-- the API types without something like `UVerb`.)+--+-- See <https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html> for a working example.+module Servant.API.UVerb+ ( UVerb,+ HasStatus (StatusOf),+ statusOf,+ HasStatuses (Statuses, statuses),+ WithStatus (..),+ module Servant.API.UVerb.Union,+ )+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 :: Type) where+ type StatusOf (a :: Type) :: Nat++statusOf :: forall a proxy. HasStatus a => proxy a -> Status+statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))++-- | If an API can respond with 'NoContent' we assume that this will happen+-- with the status code 204 No Content. If this needs to be overridden,+-- 'WithStatus' can be used.+instance HasStatus NoContent where+ type StatusOf NoContent = 204++class HasStatuses (as :: [Type]) where+ type Statuses (as :: [Type]) :: [Nat]+ statuses :: Proxy as -> [Status]++instance HasStatuses '[] where+ type Statuses '[] = '[]+ statuses _ = []++instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where+ type Statuses (a ': as) = StatusOf a ': Statuses as+ statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as)++-- | A simple newtype wrapper that pairs a type with its status code. It+-- implements all the content types that Servant ships with by default.+newtype WithStatus (k :: Nat) a = WithStatus a+ deriving (Eq, Show)++-- | an instance of this typeclass assigns a HTTP status code to a return type+--+-- Example:+--+-- @+-- data NotFoundError = NotFoundError String+--+-- instance HasStatus NotFoundError where+-- type StatusOf NotFoundError = 404+-- @+--+-- You can also use the convience newtype wrapper 'WithStatus' if you want to+-- avoid writing a 'HasStatus' instance manually. It also has the benefit of+-- showing the status code in the type; which might aid in readability.+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.+--+-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write+-- instances for 'HasServer' etc. for the latter, getting them for the former for free.+-- Something like:+--+-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@+--+-- 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 :: [Type]) (as :: [Type])++instance {-# OVERLAPPING #-} MimeRender JSON a => MimeRender JSON (WithStatus _status a) where+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a++instance {-# OVERLAPPING #-} MimeRender PlainText a => MimeRender PlainText (WithStatus _status a) where+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a++instance {-# OVERLAPPING #-} MimeRender FormUrlEncoded a => MimeRender FormUrlEncoded (WithStatus _status a) where+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a++instance {-# OVERLAPPING #-} MimeRender OctetStream a => MimeRender OctetStream (WithStatus _status a) where+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a++instance {-# OVERLAPPING #-} MimeUnrender JSON a => MimeUnrender JSON (WithStatus _status a) where+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input++instance {-# OVERLAPPING #-} MimeUnrender PlainText a => MimeUnrender PlainText (WithStatus _status a) where+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input++instance {-# OVERLAPPING #-} MimeUnrender FormUrlEncoded a => MimeUnrender FormUrlEncoded (WithStatus _status a) where+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input++instance {-# OVERLAPPING #-} MimeUnrender OctetStream a => MimeUnrender OctetStream (WithStatus _status a) where+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
+ src/Servant/API/UVerb/Union.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-++Copyright Dennis Gosnell (c) 2017-2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-}++-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by+-- [world-peace](https://github.com/cdepillabout/world-peace).+module Servant.API.UVerb.Union+( IsMember+, Unique+, Union+, inject+, eject+, foldMapUnion+, matchUnion+)+where++import Data.Kind (Type)+import Data.Proxy (Proxy)+import Data.SOP.BasicFunctors (I, unI)+import Data.SOP.Constraint+import Data.SOP.NS+import Data.Type.Bool (If)+import Data.Type.Equality (type (==))+import GHC.TypeLits++type Union = NS I++-- | Convenience function to apply a function to an unknown union element using a type class.+-- All elements of the union must have instances in the type class, and the function is+-- applied unconditionally.+--+-- See also: 'matchUnion'.+foldMapUnion ::+ forall (c :: Type -> Constraint) (a :: Type) (as :: [Type]).+ All c as =>+ Proxy c ->+ (forall x. c x => x -> a) ->+ Union as ->+ a+foldMapUnion proxy go = cfoldMap_NS proxy (go . unI)++-- | Convenience function to extract a union element using 'cast', ie. return the value if the+-- selected type happens to be the actual type of the union in this value, or 'Nothing'+-- otherwise.+--+-- See also: 'foldMapUnion'.+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++-- (this could to go sop-core, except it's probably too specialized to the servant use-case.)++type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as)++class UElem x xs where+ inject :: f x -> NS f xs+ eject :: NS f xs -> Maybe (f x)++instance {-# OVERLAPPING #-} UElem x (x ': xs) where+ inject = Z+ eject (Z x) = Just x+ eject _ = Nothing++instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where+ inject = S . inject+ eject (Z _) = Nothing+ eject (S ns) = eject ns++-- | 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))++type NoElementError (r :: k) (rs :: [k]) =+ 'Text "Expected one of:"+ ':$$: 'Text " " ':<>: 'ShowType rs+ ':$$: 'Text "But got:"+ ':$$: 'Text " " ':<>: 'ShowType r++type DuplicateElementError (rs :: [k]) =+ 'Text "Duplicate element in list:"+ ':$$: 'Text " " ':<>: 'ShowType rs++type family Elem (x :: k) (xs :: [k]) :: Bool where+ Elem x (x ': _) = 'True+ Elem x (_ ': xs) = Elem x xs+ Elem _ '[] = 'False++-- | 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))++type family Nubbed xs :: Bool where+ Nubbed '[] = 'True+ Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs)++_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False+ , Nubbed '[Int, Int, Bool] ~ 'False+ , Nubbed '[Int, Bool] ~ 'True+ )+ => a) -> a+_testNubbed a = a
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,9 +28,15 @@ -- 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.+-- It does not require either a list of content types (because there's+-- no content) or a status code (because it should always be 204).+data NoContentVerb (method :: k1)+ deriving (Typeable, Generic)+ -- * 200 responses -- -- The 200 response is the workhorse of web servers, but also fairly generic.@@ -113,16 +121,17 @@ -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code.-type GetNoContent = Verb 'GET 204+type GetNoContent = NoContentVerb 'GET -- | 'POST' with 204 status code.-type PostNoContent = Verb 'POST 204+type PostNoContent = NoContentVerb 'POST -- | 'DELETE' with 204 status code.-type DeleteNoContent = Verb 'DELETE 204+type DeleteNoContent = NoContentVerb 'DELETE -- | 'PATCH' with 204 status code.-type PatchNoContent = Verb 'PATCH 204+type PatchNoContent = NoContentVerb 'PATCH -- | 'PUT' with 204 status code.-type PutNoContent = Verb 'PUT 204-+type PutNoContent = NoContentVerb 'PUT+-- | 'HEAD' with 204 status code.+type HeadNoContent = NoContentVerb 'HEAD -- ** 205 Reset Content --
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,22 +1,16 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# 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) -- >>> import Data.Proxy -- >>> -- >>> type Hello = "hello" :> Get '[JSON] Int@@ -54,7 +48,7 @@ -- >>> toUrlPiece $ safeLink api without -- "bye" ----- If you would like create a helper for generating links only within that API,+-- If you would like to create a helper for generating links only within that API, -- you can partially apply safeLink if you specify a correct type signature -- like so: --@@ -65,7 +59,7 @@ -- >>> apiLink = safeLink api -- >>> :} ----- `safeLink'` allows to make specialise the output:+-- `safeLink'` allows you to specialise the output: -- -- >>> safeLink' toUrlPiece api without -- "bye"@@ -85,7 +79,7 @@ -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent) -- >>> safeLink api bad_link -- ...--- ...Could not deduce...+-- ...Could not ... -- ... -- -- This error is essentially saying that the type family couldn't find@@ -120,13 +114,16 @@ , Param (..) , 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 (..))-import Data.Semigroup- ((<>)) import Data.Singletons.Bool (SBool (..), SBoolI (..)) import qualified Data.Text as Text@@ -134,11 +131,9 @@ import Data.Type.Bool (If) import GHC.TypeLits- (KnownSymbol, symbolVal)+ (KnownSymbol, TypeError, symbolVal) import Network.URI (URI (..), escapeURIString, isUnreserved)-import Prelude ()-import Prelude.Compat import Servant.API.Alternative ((:<|>) ((:<|>)))@@ -152,6 +147,8 @@ (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect)+import Servant.API.Fragment+ (Fragment) import Servant.API.Generic import Servant.API.Header (Header')@@ -161,10 +158,14 @@ (IsSecure) import Servant.API.Modifiers (FoldRequired)+import Servant.API.NamedRoutes+ (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@@ -173,27 +174,39 @@ (Stream, StreamBody') import Servant.API.Sub (type (:>))+import Servant.API.TypeErrors import Servant.API.TypeLevel+import Servant.API.UVerb import Servant.API.Vault (Vault) import Servant.API.Verbs- (Verb)+ (Verb, NoContentVerb) import Servant.API.WithNamedContext (WithNamedContext)+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]+ , _fragment :: Fragment' } deriving Show newtype Escaped = Escaped String +type Fragment' = Maybe String+ escaped :: String -> Escaped-escaped = Escaped . escapeURIString isUnreserved+escaped = Escaped . escape getEscaped :: Escaped -> String getEscaped (Escaped s) = s@@ -208,11 +221,14 @@ linkQueryParams :: Link -> [Param] linkQueryParams = _queryParams +linkFragment :: Link -> Fragment'+linkFragment = _fragment+ instance ToHttpApiData Link where toHeader = TE.encodeUtf8 . toUrlPiece toUrlPiece l = let uri = linkURI l- in Text.pack $ uriPath uri ++ uriQuery uri+ in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri -- | Query parameter. data Param@@ -224,10 +240,21 @@ 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 }+ -- | Transform 'Link' into 'URI'. -- -- >>> type API = "something" :> Get '[JSON] Int@@ -245,7 +272,7 @@ -- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] () -- >>> let someRoute = Proxy :: Proxy SomeRoute -- >>> safeLink someRoute someRoute "test@example.com"--- Link {_segments = ["abc","test%40example.com"], _queryParams = []}+-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing} -- -- >>> linkURI $ safeLink someRoute someRoute "test@example.com" -- abc/test%40example.com@@ -269,22 +296,27 @@ -- sum?x=1&x=2&x=3 -- linkURI' :: LinkArrayElementStyle -> Link -> URI-linkURI' addBrackets (Link segments q_params) =+linkURI' addBrackets (Link segments q_params mfragment) = URI mempty -- No scheme (relative) Nothing -- Or authority (relative)- (intercalate "/" $ map getEscaped segments)- (makeQueries q_params) mempty+ (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) makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k + makeFragment :: Fragment' -> String+ makeFragment Nothing = ""+ makeFragment (Just fr) = "#" <> escape fr+ style = case addBrackets of LinkArrayElementBracket -> "[]=" LinkArrayElementPlain -> "="@@ -310,7 +342,7 @@ -> Proxy api -- ^ The whole API that this endpoint is a part of -> Proxy endpoint -- ^ The API endpoint you would like to point to -> MkLink endpoint a-safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty) -- | Create all links in an API. --@@ -327,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@@ -341,7 +373,7 @@ => (Link -> a) -> Proxy api -> MkLink api a-allLinks' toA api = toLink toA api (Link mempty mempty)+allLinks' toA api = toLink toA api (Link mempty mempty mempty) ------------------------------------------------------------------------------- -- Generics@@ -363,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 @@ -375,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)@@ -386,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 @@ -422,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@@ -457,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) @@ -499,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) @@ -529,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)@@ -546,20 +584,69 @@ type MkLink (Verb m s ct a) r = r toLink toA _ = toA +instance HasLink (NoContentVerb m) where+ type MkLink (NoContentVerb m) r = r+ toLink toA _ = toA+ instance HasLink Raw where 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 +-- UVerb instances+instance HasLink (UVerb m ct a) where+ type MkLink (UVerb m ct a) r = r+ toLink toA _ = toA+-- Instance for NamedRoutes combinator++type GLinkConstraints routes a =+ ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)+ , GenericServant routes (AsLink a)+ )++class GLink (routes :: Type -> Type) (a :: Type) where+ gLinkProof :: Dict (GLinkConstraints routes a)++instance GLinkConstraints routes a => GLink routes a where+ gLinkProof = Dict++instance+ ( HasLink (ToServantApi routes)+ , forall a. GLink routes a+ , ErrorIfNoGeneric routes+ ) => HasLink (NamedRoutes routes) where++ type MkLink (NamedRoutes routes) a = routes (AsLink a)++ toLink+ :: forall a. (Link -> a)+ -> Proxy (NamedRoutes routes)+ -> Link+ -> routes (AsLink a)++ toLink toA _ l = case gLinkProof @routes @a of+ Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l+ -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where type MkLink (AuthProtect tag :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) --- | Helper for implemneting 'toLink' for combinators not affecting link+instance (HasLink sub, ToHttpApiData v)+ => HasLink (Fragment v :> sub) where+ type MkLink (Fragment v :> sub) a = v -> MkLink sub a+ toLink toA _ l mv =+ toLink toA (Proxy :: Proxy sub) $+ addFragment ((Just . Text.unpack . toQueryParam) mv) l++-- | Helper for implementing 'toLink' for combinators not affecting link -- structure. simpleToLink :: forall sub a combinator.@@ -575,3 +662,50 @@ -- $setup -- >>> import Servant.API -- >>> import Data.Text (Text)++-- Erroring instance for 'HasLink' when a combinator is not fully applied+instance TypeError (PartialApplication+#if __GLASGOW_HASKELL__ >= 904+ @(Type -> Constraint)+#endif+ HasLink arr) => HasLink ((arr :: a -> b) :> sub)+ where+ 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+#if __GLASGOW_HASKELL__ >= 904+ @(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
@@ -48,7 +48,8 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint = GET :<|> "get-int" :> Get '[JSON] Int- :<|> "capture" :> Capture' '[Description "example description"] "foo" Int :> GET+ :<|> "capture" :> Capture' '[Description "example description"] "bar" Int :> GET+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET :<|> "header" :> Header "foo" Int :> GET :<|> "header-lenient" :> Header' '[Required, Lenient] "bar" Int :> GET :<|> "http-version" :> HttpVersion :> GET@@ -63,13 +64,15 @@ :<|> "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> "foo" :> GET :<|> "vault" :> Vault :> GET- :<|> "post-no-content" :> Verb 'POST 204 '[JSON] NoContent+ :<|> "post-no-content" :> PostNoContent :<|> "post-int" :> Verb 'POST 204 '[JSON] Int :<|> "named-context" :> WithNamedContext "foo" '[] GET :<|> "capture-all" :> CaptureAll "foo" Int :> GET :<|> "summary" :> Summary "foo" :> GET :<|> "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,8 +83,23 @@ -- 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)))))+--+instance Functor m => Semigroup (SourceT m a) where+ SourceT withL <> SourceT withR = SourceT $ \ret ->+ withL $ \l ->+ withR $ \r ->+ ret $ l <> r++-- | >>> mempty :: SourceT Maybe Int+-- fromStepT (Effect (Just Stop))+instance Functor m => Monoid (SourceT m a) where+ mempty = fromStepT mempty+ mappend = (<>)+ -- | Doesn't generate 'Error' constructors. 'SourceT' doesn't shrink. instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (SourceT m a) where arbitrary = fromStepT <$> QC.arbitrary@@ -136,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@@ -150,6 +167,23 @@ go (Yield x s) = Yield x (go s) go (Effect ms) = Effect (f (fmap go ms)) +instance Functor m => Semigroup (StepT m a) where+ Stop <> r = r+ Error err <> _ = Error err+ Skip s <> r = Skip (s <> r)+ Yield x s <> r = Yield x (s <> r)+ Effect ms <> r = Effect ((<> r) <$> ms)++-- | >>> mempty :: StepT [] Int+-- Stop+--+-- >>> mempty :: StepT Identity Int+-- Stop+--+instance Functor m => Monoid (StepT m a) where+ mempty = Stop+ mappend = (<>)+ -- | Doesn't generate 'Error' constructors. instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (StepT m a) where arbitrary = QC.sized arb where@@ -157,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@@ -180,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.@@ -195,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)@@ -206,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 _) = -}@@ -237,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'@@ -258,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 -------------------------------------------------------------------------------@@ -287,8 +337,8 @@ -- | Read file. -- -- >>> foreach fail BS.putStr (readFile "servant.cabal")--- cabal-version: >=1.10--- name: servant+-- cabal-version: 3.0+-- name: servant -- ... -- readFile :: FilePath -> SourceT IO BS.ByteString@@ -310,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
− src/Servant/Utils/Links.hs
@@ -1,6 +0,0 @@-module Servant.Utils.Links- {-# DEPRECATED "Use Servant.Links." #-}- ( module Servant.Links )- where--import Servant.Links
test/Servant/API/ContentTypesSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -7,33 +8,30 @@ {-# 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 import Data.Function (on) import Data.List- (maximumBy)+ (sortBy) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust, isJust, isNothing) 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+import Control.Exception+ (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@@ -77,6 +75,15 @@ it "has mimeUnrender reverse mimeRender for valid top-level json " $ do property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData) + describe "The NoContent Content-Type type" $ do+ let p = Proxy :: Proxy '[JSON]++ it "does not render any content" $+ allMimeRender p NoContent `shouldSatisfy` all (BSL8.null . snd)++ it "evaluates the NoContent value" $+ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall+ describe "The PlainText Content-Type type" $ do let p = Proxy :: Proxy PlainText @@ -134,17 +141,28 @@ == Just ("application/json;charset=utf-8", encode x) it "respects the Accept spec ordering" $ do- let highest a b c = maximumBy (compare `on` snd)+ let highest a b c = last $ sortBy (compare `on` snd)+-- when qualities are same, http-media-0.8 picks first; 0.7 last.+#if MIN_VERSION_http_media(0,8,0)+ [ ("text/plain;charset=utf-8", c)+ , ("application/json;charset=utf-8", b)+ , ("application/octet-stream", a)+ ]+#else [ ("application/octet-stream", a) , ("application/json;charset=utf-8", b) , ("text/plain;charset=utf-8", c) ]+#endif let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $- addToAccept (Proxy :: Proxy JSON) b $- addToAccept (Proxy :: Proxy PlainText ) c ""+ addToAccept (Proxy :: Proxy JSON) b $+ 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 -> fst (fromJust $ val a b c i) == fst (highest a b c)+ property $ \a b c i ->+ let acc = acceptH a b c+ in counterexample (show acc) $+ fst (fromJust $ val a b c i) === fst (highest a b c) describe "handleCTypeH" $ do @@ -195,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)@@ -222,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 ]@@ -243,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@@ -255,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/API/StreamSpec.hs view
@@ -90,7 +90,7 @@ runRenderFrames f = fmap mconcat . runExcept . runSourceT . f . source runUnrenderFrames :: (SourceT Identity b -> SourceT Identity a) -> [b] -> [Either String a]-runUnrenderFrames f = go . Effect . flip unSourceT return . f . source where+runUnrenderFrames f = go . Effect . (\x -> unSourceT x return) . f . source where go :: StepT Identity a -> [Either String a] go Stop = [] go (Error err) = [Left err]
test/Servant/LinksSpec.hs view
@@ -1,21 +1,29 @@ {-# 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)-import Servant.Links type TestApi = -- Capture and query params@@ -26,6 +34,15 @@ -- Flags :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent + -- Fragment+ :<|> "say" :> Fragment String :> Get '[JSON] NoContent++ -- 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@@ -38,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@@ -70,12 +137,20 @@ ["roads", "lead", "to", "rome"] `shouldBeLink` "all/roads/lead/to/rome" + it "generated correct links for UVerbs" $ do+ apiLink (Proxy :: Proxy ("uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent]))+ `shouldBeLink` "uverb-example"+ it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent) apiLink l1 True True `shouldBeLink` "balls?bouncy&fast" apiLink l1 False True `shouldBeLink` "balls?fast" + it "generates correct link for fragment" $ do+ let l1 = Proxy :: Proxy ("say" :> Fragment String :> Get '[JSON] NoContent)+ apiLink l1 "something" `shouldBeLink` "say#something"+ it "generates correct links for all of the verbs" $ do apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get" apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"@@ -91,6 +166,41 @@ 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. -- | -- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,
− test/doctests.hs
@@ -1,27 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Main (doctests)--- Copyright : (C) 2012-14 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module provides doctests for a project based on the actual versions--- of the packages it was built with. It requires a corresponding Setup.lhs--- to be added to the project-------------------------------------------------------------------------------module Main where--import Build_doctests- (flags, module_sources, pkgs)-import Data.Foldable- (traverse_)-import Test.DocTest--main :: IO ()-main = do- traverse_ putStrLn args- doctest args- where- args = flags ++ pkgs ++ module_sources