servant 0.12.1 → 0.20.3.0
raw patch · 57 files changed
Files
- CHANGELOG.md +846/−1
- LICENSE +1/−1
- Setup.hs +2/−0
- Setup.lhs +0/−31
- include/overlapping-compat.h +0/−8
- servant.cabal +152/−118
- src/Servant/API.hs +110/−51
- src/Servant/API/Alternative.hs +28/−10
- src/Servant/API/BasicAuth.hs +12/−7
- src/Servant/API/Capture.hs +12/−6
- src/Servant/API/ContentTypes.hs +61/−67
- src/Servant/API/Description.hs +52/−7
- src/Servant/API/Empty.hs +1/−3
- src/Servant/API/Experimental/Auth.hs +5/−4
- src/Servant/API/Fragment.hs +27/−0
- src/Servant/API/Generic.hs +149/−0
- src/Servant/API/Header.hs +15/−10
- src/Servant/API/Host.hs +13/−0
- src/Servant/API/HttpVersion.hs +2/−1
- src/Servant/API/Internal/Test/ComprehensiveAPI.hs +0/−46
- src/Servant/API/IsSecure.hs +4/−2
- src/Servant/API/Modifiers.hs +155/−0
- src/Servant/API/MultiVerb.hs +500/−0
- src/Servant/API/NamedRoutes.hs +12/−0
- src/Servant/API/QueryParam.hs +15/−6
- src/Servant/API/QueryString.hs +86/−0
- src/Servant/API/Range.hs +68/−0
- src/Servant/API/Raw.hs +9/−3
- src/Servant/API/RemoteHost.hs +1/−0
- src/Servant/API/ReqBody.hs +15/−3
- src/Servant/API/ResponseHeaders.hs +176/−71
- src/Servant/API/ServerSentEvents.hs +37/−0
- src/Servant/API/Status.hs +160/−0
- src/Servant/API/Stream.hs +236/−0
- src/Servant/API/Sub.hs +5/−2
- src/Servant/API/TypeErrors.hs +59/−0
- src/Servant/API/TypeLevel.hs +93/−40
- 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/Vault.hs +2/−1
- src/Servant/API/Verbs.hs +34/−19
- src/Servant/API/WithNamedContext.hs +5/−3
- src/Servant/API/WithResource.hs +3/−0
- src/Servant/Links.hs +711/−0
- src/Servant/Test/ComprehensiveAPI.hs +81/−0
- src/Servant/Types/Internal/Response.hs +17/−0
- src/Servant/Types/SourceT.hs +399/−0
- src/Servant/Utils/Enter.hs +0/−122
- src/Servant/Utils/Links.hs +0/−367
- test/Servant/API/ContentTypesSpec.hs +58/−37
- test/Servant/API/ResponseHeadersSpec.hs +23/−4
- test/Servant/API/StreamSpec.hs +99/−0
- test/Servant/LinksSpec.hs +250/−0
- test/Servant/Utils/EnterSpec.hs +0/−33
- test/Servant/Utils/LinksSpec.hs +0/−129
- test/doctests.hs +0/−25
CHANGELOG.md view
@@ -1,5 +1,850 @@ [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+----++### Significant changes++- Streaming refactoring.+ [#991](https://github.com/haskell-servant/servant/pull/991)+ [#1076](https://github.com/haskell-servant/servant/pull/1076)+ [#1077](https://github.com/haskell-servant/servant/pull/1077)++ The streaming functionality (`Servant.API.Stream`) is refactored to use+ `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation),+ which replaces both `StreamGenerator` and `ResultStream` types.++ New conversion type-classes are `ToSourceIO` and `FromSourceIO`+ (replacing `ToStreamGenerator` and `BuildFromStream`).+ There are instances for *conduit*, *pipes* and *machines* in new packages:+ [servant-conduit](https://hackage.haskell.org/package/servant-conduit)+ [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and+ [servant-machines](https://hackage.haskell.org/package/servant-machines)+ respectively.++ Writing new framing strategies is simpler. Check existing strategies for examples.++ This change shouldn't affect you, if you don't use streaming endpoints.++- *servant-client* Separate streaming client.+ [#1066](https://github.com/haskell-servant/servant/pull/1066)++ We now have two `http-client` based clients,+ in `Servant.Client` and `Servant.Client.Streaming`.++ Their API is the same, except for+ - `Servant.Client` **cannot** request `Stream` endpoints.+ - `Servant.Client` is *run* by direct+ `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)`+ - `Servant.Client.Streaming` **can** request `Stream` endpoints.+ - `Servant.Client.Streaming` is *used* by CPSised+ `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b`++ To access `Stream` endpoints use `Servant.Client.Streaming` with+ `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`.+ You can use both too, `ClientEnv` and `BaseUrl` types are same for both.++ **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints.+ Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until+ the whole response is received.++ There is `Servant.Client.Streaming.runClientM` function, but it has+ restricted type. `NFData a` constraint prevents using it with+ `SourceT`, `Conduit` etc. response types.++ ```haskell+ runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)+ ```++ This change shouldn't affect you, if you don't use streaming endpoints.++- *servant-client-core* Related to the previous:+ `streamingResponse` is removed from `RunClient`.+ We have a new type-class:++ ```haskell+ class RunClient m => RunStreamingClient m where+ withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a+ ```++- Drop support for GHC older than 8.0+ [#1008](https://github.com/haskell-servant/servant/pull/1008)+ [#1009](https://github.com/haskell-servant/servant/pull/1009)++- *servant* `ComprehensiveAPI` is a part of public API in `Servant.Test.ComprehensiveAPI` module.+ This API type is used to verify that libraries implement all core combinators.+ Now we won't change this type between major versions.+ (This has been true for some time already).+ [#1070](https://github.com/haskell-servant/servant/pull/1070)++- *servant* Remove `Servant.Utils.Enter` module+ (deprecated in `servant-0.12` in favour of `hoistServer`)+ [#996](https://github.com/haskell-servant/servant/pull/996)++- *servant-foreign* Add support so `HasForeign` can be implemented for+ `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart)+ [#1035](https://github.com/haskell-servant/servant/pull/1035)++### Other changes++- *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances.+ [#1076](https://github.com/haskell-servant/servant/pull/1076)++- *servant* NewlineFraming encodes newline after each element (i.e last)+ [#1079](https://github.com/haskell-servant/servant/pull/1079)+ [#1011](https://github.com/haskell-servant/servant/issues/1011)++- *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a`+ [#1064](https://github.com/haskell-servant/servant/pull/1064)++- *servant-server* Add `MonadMask Handler`+ [#1068](https://github.com/haskell-servant/servant/pull/1068)++- *servant-docs* Fix markdown indentation+ [#1043](https://github.com/haskell-servant/servant/pull/1043)++- *servant* Export `GetHeaders'`+ [#1052](https://github.com/haskell-servant/servant/pull/1052)++- *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>`+ [#1032](https://github.com/haskell-servant/servant/pull/1032)++- *servant* Add `PutCreated` method type alias+ [#1024](https://github.com/haskell-servant/servant/pull/1024)++- *servant-client-core* Add `aeson` and `Lift BaseUrl` instances+ [#1037](https://github.com/haskell-servant/servant/pull/1037)++- *servant* Add `ToSourceIO (NonEmpty a)` instance+ [#988](https://github.com/haskell-servant/servant/pull/988)++- Development process improvements+ - Apply `stylish-haskell` to all modules+ [#1001](https://github.com/haskell-servant/servant/pull/1001)+ - Amend `CONTRIBUTING.md`+ [#1036](https://github.com/haskell-servant/servant/pull/1036)+ - `servant-docs` has golden tests for `ComprehensiveAPI`+ [#1071](https://github.com/haskell-servant/servant/pull/1071)+ - Other+ [#1039](https://github.com/haskell-servant/servant/pull/1039)+ [#1046](https://github.com/haskell-servant/servant/pull/1046)+ [#1062](https://github.com/haskell-servant/servant/pull/1062)+ [#1069](https://github.com/haskell-servant/servant/pull/1069)+ [#985](https://github.com/haskell-servant/servant/pull/985)++- *Documentation* Tutorial and new recipes+ - [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://docs.servant.dev/en/latest/cookbook/curl-mock/CurlMock.html)+ [#1033](https://github.com/haskell-servant/servant/pull/1033)+ - [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://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://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://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)+ [#1007](https://github.com/haskell-servant/servant/pull/1007)+ - miscellanea: fixed typos etc.+ [#1030](https://github.com/haskell-servant/servant/pull/1030)+ [#1020](https://github.com/haskell-servant/servant/pull/1020)+ [#1059](https://github.com/haskell-servant/servant/pull/1059)++- *Documentation* README+ [#1010](https://github.com/haskell-servant/servant/pull/1010)++- *servant-client-ghcjs* updates. **note** package is not released on Hackage+ [#938](https://github.com/haskell-servant/servant/pull/938)++0.14.1+------++- Merge in (and slightly refactor) `servant-generic`+ (by [Patrick Chilton](https://github.com/chpatrick))+ into `servant` (`Servant.API.Generic`),+ `servant-client-code` (`Servant.Client.Generic`)+ and `servant-server` (`Servant.Server.Generic`).++- Deprecate `Servant.Utils.Links`, use `Servant.Links`.+ [#998](https://github.com/haskell-servant/servant/pull/998)++- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.++0.14+----++### Significant changes++- `Stream` takes a status code argument++ ```diff+ -Stream method framing ctype a+ +Stream method status framing ctype a+ ```++ ([#966](https://github.com/haskell-servant/servant/pull/966)+ [#972](https://github.com/haskell-servant/servant/pull/972))++- `ToStreamGenerator` definition changed, so it's possible to write an instance+ for conduits.++ ```diff+ -class ToStreamGenerator f a where+ - toStreamGenerator :: f a -> StreamGenerator a+ +class ToStreamGenerator a b | a -> b where+ + toStreamGenerator :: a -> StreamGenerator b+ ```++ ([#959](https://github.com/haskell-servant/servant/pull/959))++- Added `NoFraming` streaming strategy+ ([#959](https://github.com/haskell-servant/servant/pull/959))++- *servant-client-core* Free `Client` implementation.+ Useful for testing `HasClient` instances.+ ([#920](https://github.com/haskell-servant/servant/pull/920))++- *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, we also have `hoistClient` for changing the monad+ in which *client functions* live.+ 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+ `HasClient` class, for example:++ ```haskell+ type Client m (MyCombinator :> api) = MyValue :> Client m api+ hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl+ ```++- *servant* Add `safeLink' :: (Link -> a) -> ... -> MkLink endpoint a`,+ which allows to create helpers returning something else than `Link`.+ ([#968](https://github.com/haskell-servant/servant/pull/968))++- *servant-server* File serving in polymorphic monad.+ i.e. Generalised types of `serveDirectoryFileServer` etc functions in+ `Servant.Utils.StaticFiles`+ ([#953](https://github.com/haskell-servant/servant/pull/953))++- *servant-server* `ReqBody` content type check is recoverable.+ This allows writing APIs like:++ ```haskell+ ReqBody '[JSON] Int :> Post '[PlainText] Int+ :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int+ ```++ which is useful when handlers are subtly different,+ for example may do less work.+ ([#937](https://github.com/haskell-servant/servant/pull/937))++- *servant-client* Add more constructors to `RequestBody`, including+ `RequestBodyStream`.+ *Note:* we are looking for http-library agnostic API,+ so the might change again soon.+ Tell us which constructors are useful for you!+ ([#913](https://github.com/haskell-servant/servant/pull/913))++### Other changes++- `GetHeaders` instances implemented without `OverlappingInstances`+ ([#971](https://github.com/haskell-servant/servant/pull/971))++- Added tests or enabled tests+ ([#975](https://github.com/haskell-servant/servant/pull/975))++- 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://docs.servant.dev/en/release-0.14/cookbook/structuring-apis/StructuringApis.html)+ ([#929](https://github.com/haskell-servant/servant/pull/929))++- Dependency updates+ ([#900](https://github.com/haskell-servant/servant/pull/900)+ [#919](https://github.com/haskell-servant/servant/pull/919)+ [#924](https://github.com/haskell-servant/servant/pull/924)+ [#943](https://github.com/haskell-servant/servant/pull/943)+ [#964](https://github.com/haskell-servant/servant/pull/964)+ [#967](https://github.com/haskell-servant/servant/pull/967)+ [#976](https://github.com/haskell-servant/servant/pull/976))++- Documentation updates+ [#963](https://github.com/haskell-servant/servant/pull/963)+ [#960](https://github.com/haskell-servant/servant/pull/960)+ [#908](https://github.com/haskell-servant/servant/pull/908)+ [#958](https://github.com/haskell-servant/servant/pull/958)+ [#948](https://github.com/haskell-servant/servant/pull/948)+ [#928](https://github.com/haskell-servant/servant/pull/928)+ [#921](https://github.com/haskell-servant/servant/pull/921))++- Development process improvements+ ([#680](https://github.com/haskell-servant/servant/pull/680)+ [#917](https://github.com/haskell-servant/servant/pull/917)+ [#923](https://github.com/haskell-servant/servant/pull/923)+ [#961](https://github.com/haskell-servant/servant/pull/961)+ [#973](https://github.com/haskell-servant/servant/pull/973))++### Note++(VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant\/pull\/\1)/`++0.13.0.1+--------++- Support `base-compat-0.10`++0.13+----++### Significant changes++- Streaming endpoint support.+ ([#836](https://github.com/haskell-servant/servant/pull/836))++ ```haskell+ type StreamApi f = "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)+ ```++ See tutorial for more details+ - [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)+ [#903](https://github.com/haskell-servant/servant/pull/903))++ `QueryParam`, `Header` and `ReqBody` understand modifiers:+ - `Required` or `Optional` (resulting in `a` or `Maybe a` in handlers)+ - `Strict` or `Lenient` (resulting in `a` or `Either String a` in handlers)++ Also you can use `Description` as a modifier, but it doesn't yet work+ with `servant-docs`, only `servant-swagger`. [There is an issue.](https://github.com/haskell-servant/servant/issues/902)++- *servant-client* Support `http-client`’s `CookieJar`+ ([#897](https://github.com/haskell-servant/servant/pull/897)+ [#883](https://github.com/haskell-servant/servant/pull/883))++ `ClientM` preserves cookies between requests,+ if given initial `CookieJar`.+ To migrate from older code, change `ClientEnv` constructor+ to `mkClientEnv` which makes `ClientEnv` without `CookieJar`.++- *servant* Mono-kind-ise modifiers, resulting in better error messages.+ ([#887](https://github.com/haskell-servant/servant/issues/887)+ [#890](https://github.com/haskell-servant/servant/pull/890))++- *servant* Add `TypeError ... => HasServer`s instances in GHC-8.2 for+ not saturated modifiers (`Capture "foo" :> ...`) or `->` in place of `:>`.+ ([#893](https://github.com/haskell-servant/servant/pull/893))++- *Cookbook* example projects at+ 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))++- *Experimental work* `servant-client-ghcjs`+ ([#818](https://github.com/haskell-servant/servant/pull/818)+ [#869](https://github.com/haskell-servant/servant/pull/869))++### Other changes++- *servant* Links aren't double escaped+ ([#878](https://github.com/haskell-servant/servant/pull/878))++- Dependency updates+ ([#900](https://github.com/haskell-servant/servant/pull/900)+ [#898](https://github.com/haskell-servant/servant/pull/898)+ [#895](https://github.com/haskell-servant/servant/pull/895)+ [#872](https://github.com/haskell-servant/servant/pull/872))++- Documentation updates+ ([#875](https://github.com/haskell-servant/servant/pull/875)+ [#861](https://github.com/haskell-servant/servant/pull/861))++- Refactorings+ ([#899](https://github.com/haskell-servant/servant/pull/899)+ [#896](https://github.com/haskell-servant/servant/pull/896)+ [#889](https://github.com/haskell-servant/servant/pull/889)+ [#891](https://github.com/haskell-servant/servant/pull/891)+ [#892](https://github.com/haskell-servant/servant/pull/892)+ [#885](https://github.com/haskell-servant/servant/pull/885))+ 0.12.1 ------ @@ -41,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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,31 +0,0 @@-\begin{code}-{-# 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-#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 ()-main = defaultMain--#endif--\end{code}
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant.cabal view
@@ -1,41 +1,82 @@-name: servant-version: 0.12.1-synopsis: A family of combinators for defining webservices APIs+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, Servant Contributors-category: Servant, Web-build-type: Custom-cabal-version: >=1.10-tested-with:- GHC==7.8.4- GHC==7.10.3- GHC==8.0.2- GHC==8.2.1-extra-source-files:- include/*.h- CHANGELOG.md++homepage: http://docs.servant.dev/+bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD-3-Clause+license-file: LICENSE+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright:+ 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors++build-type: Simple+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+ 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.2 && <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@@ -45,119 +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.Internal.Test.ComprehensiveAPI 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.Utils.Links- Servant.Utils.Enter+ Servant.API.WithResource++ -- Types+ exposed-modules:+ Servant.Types.SourceT+ Servant.Types.Internal.Response++ -- Test stuff+ exposed-modules: Servant.Test.ComprehensiveAPI++ -- Safe links+ exposed-modules: Servant.Links++ -- Bundled with GHC: Lower bound to not force re-installs+ -- text and mtl are bundled starting with GHC-8.4+ --+ -- note: mtl lower bound is so low because of GHC-7.8 build-depends:- base >= 4.7 && < 4.11- , base-compat >= 0.9 && < 0.10- , aeson >= 0.7 && < 1.3- , attoparsec >= 0.12 && < 0.14- , bytestring >= 0.10 && < 0.11- , case-insensitive >= 1.2 && < 1.3- , http-api-data >= 0.3 && < 0.4- , http-media >= 0.4 && < 0.8- , http-types >= 0.8 && < 0.12- , natural-transformation >= 0.4 && < 0.5- , mtl >= 2.0 && < 2.3- , mmorph >= 1 && < 1.2- , tagged >= 0.7.3 && < 0.9- , text >= 1 && < 1.3- , string-conversions >= 0.3 && < 0.5- , network-uri >= 2.6 && < 2.7- , vault >= 0.3 && < 0.4+ , 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 - if !impl(ghc >= 8.0)- build-depends:- semigroups >= 0.16 && < 0.19+ -- We depend (heavily) on the API of these packages:+ -- i.e. re-export, or allow using without direct dependency+ build-depends:+ , http-api-data >=0.4.1 && <0.7+ , singleton-bool >=0.1.4 && <0.2 - 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- if impl(ghc >= 8.0)- ghc-options: -Wno-redundant-constraints- include-dirs: include+ -- 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:+ , 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+ 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.Utils.LinksSpec- Servant.Utils.EnterSpec- build-tool-depends:- hspec-discover:hspec-discover+ Servant.API.ContentTypesSpec+ Servant.API.ResponseHeadersSpec+ Servant.API.StreamSpec+ Servant.LinksSpec++ -- Dependencies inherited from the library. No need to specify bounds. build-depends:- base == 4.*- , base-compat , aeson- , aeson-compat >=0.3.3 && <0.4- , attoparsec+ , base , bytestring- , hspec == 2.*- , QuickCheck- , quickcheck-instances+ , http-media+ , mtl+ , network-uri , servant- , string-conversions , text- , url - if !impl(ghc >= 8.0)- build-depends:- semigroups >= 0.16 && < 0.19+ -- Additional dependencies+ build-depends:+ , hspec >=2.6.0 && <2.12+ , QuickCheck >=2.12.6.1 && <2.16+ , quickcheck-instances >=0.3.19 && <0.4 -test-suite doctests- build-depends: base- , servant- , doctest- , filemanip- , directory- , filepath- , hspec- 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- include-dirs: include- x-doctest-source-dirs: test- x-doctest-modules: Servant.Utils.LinksSpec+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12
src/Servant/API.hs view
@@ -7,16 +7,24 @@ -- | Type-level combinator for alternative endpoints: @':<|>'@ module Servant.API.Empty, -- | Type-level combinator for an empty API: @'EmptyAPI'@+ module Servant.API.Modifiers,+ -- | Type-level modifiers for 'QueryParam', 'Header' and 'ReqBody'. -- * Accessing information from the request 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,@@ -27,10 +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, @@ -58,57 +79,95 @@ module Servant.API.Experimental.Auth, -- | General Authentication - -- * Utilities- module Servant.Utils.Links,+ -- * Links+ module Servant.Links, -- | Type-safe internal URIs++ -- * Re-exports+ If,+ SBool (..), SBoolI (..) ) where -import Servant.API.Alternative ((:<|>) (..))-import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))-import Servant.API.Capture (Capture, CaptureAll)-import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,- JSON,- MimeRender (..), NoContent (NoContent),- MimeUnrender (..), OctetStream,- PlainText)-import Servant.API.Description (Description, Summary)-import Servant.API.Empty (EmptyAPI (..))-import Servant.API.Experimental.Auth (AuthProtect)-import Servant.API.Header (Header (..))-import Servant.API.HttpVersion (HttpVersion (..))-import Servant.API.IsSecure (IsSecure (..))-import Servant.API.QueryParam (QueryFlag, QueryParam,- QueryParams)-import Servant.API.Raw (Raw)-import Servant.API.RemoteHost (RemoteHost)-import Servant.API.ReqBody (ReqBody)-import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader,- BuildHeadersTo (buildHeadersTo),- GetHeaders (getHeaders),- HList (..), Headers (..),- getHeadersHList, getResponse)-import Servant.API.Sub ((:>))-import Servant.API.Vault (Vault)-import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,- DeleteNoContent,- DeleteNonAuthoritative, Get,- GetAccepted, GetNoContent,- GetNonAuthoritative,- GetPartialContent,- GetResetContent,- Patch,- PatchAccepted, PatchNoContent,- PatchNoContent,- PatchNonAuthoritative, Post,- PostAccepted, PostNoContent,- PostNonAuthoritative,- PostResetContent, Put,- PutAccepted, PutNoContent,- PutNoContent, PutNonAuthoritative,- ReflectMethod (reflectMethod),- Verb, StdMethod(..))-import Servant.API.WithNamedContext (WithNamedContext)-import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem',- URI (..), safeLink)-import Web.HttpApiData (FromHttpApiData (..),- ToHttpApiData (..))+import Data.Singletons.Bool+ (SBool (..), SBoolI (..))+import Data.Type.Bool+ (If)+import Servant.API.Alternative+ ((:<|>) (..))+import Servant.API.BasicAuth+ (BasicAuth, BasicAuthData (..))+import Servant.API.Capture+ (Capture, Capture', CaptureAll)+import Servant.API.ContentTypes+ (Accept (..), FormUrlEncoded, JSON, MimeRender (..),+ MimeUnrender (..), NoContent (NoContent), OctetStream,+ PlainText)+import Servant.API.Description+ (Description, Summary)+import Servant.API.Empty+ (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, RawM)+import Servant.API.RemoteHost+ (RemoteHost)+import Servant.API.ReqBody+ (ReqBody, ReqBody')+import Servant.API.ResponseHeaders+ (AddHeader, BuildHeadersTo (buildHeadersTo),+ GetHeaders (getHeaders), HList (..), HasResponseHeader,+ 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,+ StreamBody, StreamBody', StreamGet, StreamPost,+ 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,+ 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+ (FromHttpApiData (..), ToHttpApiData (..))
src/Servant/API/Alternative.hs view
@@ -1,16 +1,22 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where -import Data.Semigroup (Semigroup (..))-import Data.Typeable (Typeable)-import Prelude ()-import Prelude.Compat+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+import Data.Biapplicative+ (Biapplicative (..))+import Data.Bifoldable+ (Bifoldable (..))+import Data.Bifunctor+ (Bifunctor (..))+import Data.Bitraversable+ (Bitraversable (..))+import Data.Typeable+ (Typeable) -- | Union of two APIs, first takes precedence in case of overlap. --@@ -21,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@@ -29,7 +35,19 @@ 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++instance Bifunctor (:<|>) where+ bimap f g ~(a :<|> b) = f a :<|> g b++instance Biapplicative (:<|>) where+ bipure = (:<|>)+ (f :<|> g) <<*>> (a :<|> b) = f a :<|> g b++instance Bitraversable (:<|>) where+ bitraverse f g ~(a :<|> b) = liftA2 (:<|>) (f a) (g b) -- $setup -- >>> import Servant.API
src/Servant/API/BasicAuth.hs view
@@ -1,13 +1,18 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PolyKinds #-}+ module Servant.API.BasicAuth where -import Data.ByteString (ByteString)-import Data.Typeable (Typeable)-import GHC.TypeLits (Symbol)+import Data.ByteString+ (ByteString)+import Data.Kind+ (Type)+import Data.Typeable+ (Typeable)+import GHC.TypeLits+ (Symbol) -- | Combinator for <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>.@@ -21,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
@@ -2,19 +2,25 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-}-module Servant.API.Capture (Capture, CaptureAll) where+module Servant.API.Capture (Capture, Capture', CaptureAll) where -import Data.Typeable (Typeable)-import GHC.TypeLits (Symbol)+import Data.Kind+ (Type)+import Data.Typeable+ (Typeable)+import GHC.TypeLits+ (Symbol) -- | Capture a value from the request path under a certain type @a@. -- -- Example: -- -- >>> -- GET /books/:isbn -- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book-data Capture (sym :: Symbol) a- deriving (Typeable)+type Capture = Capture' '[] -- todo +-- | 'Capture' which can be modified. For example with 'Description'.+data Capture' (mods :: [Type]) (sym :: Symbol) (a :: Type)+ deriving (Typeable) -- | Capture all remaining values from the request path under a certain type -- @a@.@@ -23,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
@@ -1,8 +1,8 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -14,8 +14,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -#include "overlapping-compat.h"- -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from@@ -23,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,@@ -51,6 +49,7 @@ , PlainText , FormUrlEncoded , OctetStream+ , EventStream -- * Building your own Content-Type , Accept(..)@@ -69,44 +68,43 @@ , AllMimeUnrender(..) , eitherDecodeLenient , canHandleAcceptH+ , EventStreamChunk(..) ) where -import Control.Arrow (left)-import Control.Monad.Compat-import Data.Aeson (FromJSON(..), ToJSON(..), encode)-import Data.Aeson.Parser (value)-import Data.Aeson.Types (parseEither)-import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,- skipSpace, (<?>))+import Control.Arrow+ (left)+import Control.DeepSeq+ (NFData)+import Data.Aeson+ (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.ByteString.Lazy+ (ByteString, fromStrict, toStrict)+import Data.Kind+ (Type) import qualified Data.List.NonEmpty as NE-import Data.Maybe (isJust)-import Data.String.Conversions (cs)+import Data.Maybe+ (isJust) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable-import GHC.Generics (Generic)-import qualified Network.HTTP.Media as M-import Web.FormUrlEncoded (FromForm, ToForm,- urlEncodeAsForm,- urlDecodeAsForm)-import Prelude ()-import Prelude.Compat--#if MIN_VERSION_base(4,9,0)+import GHC.Generics+ (Generic) import qualified GHC.TypeLits as TL-#endif+import qualified Network.HTTP.Media as M+import Web.FormUrlEncoded+ (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) -- * Provided content types data JSON deriving Typeable 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,24 +175,22 @@ 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). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} (Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs -#if MIN_VERSION_base(4,9,0) instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTRender '[] () where handleAcceptH _ _ _ = error "unreachable"-#endif -------------------------------------------------------------------------- -- * Unrender@@ -229,7 +229,7 @@ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} -class AllCTUnrender (list :: [*]) a where+class AllCTUnrender (list :: [Type]) a where canHandleCTypeH :: Proxy list -> ByteString -- Content-Type header@@ -243,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@@ -266,23 +266,23 @@ -------------------------------------------------------------------------- -- 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 -instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where+instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp where bs = mimeRender pctyp a pctyp = Proxy :: Proxy ctyp -instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where allMimeRender _ a =- (map (, bs) $ NE.toList $ contentTypes pctyp)+ map (, bs) (NE.toList $ contentTypes pctyp) ++ allMimeRender pctyps a where bs = mimeRender pctyp a@@ -293,20 +293,20 @@ -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and -- 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+instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp where pctyp = Proxy :: Proxy ctyp -instance OVERLAPPING_+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)] @@ -317,10 +317,10 @@ , AllMimeUnrender ctyps a ) => AllMimeUnrender (ctyp ': ctyps) a where allMimeUnrender _ =- (map mk $ NE.toList $ contentTypes pctyp)+ map mk (NE.toList $ contentTypes pctyp) ++ allMimeUnrender pctyps where- mk ct = (ct, \bs -> mimeUnrenderWithType pctyp ct bs)+ mk ct = (ct, mimeUnrenderWithType pctyp ct) pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps @@ -328,14 +328,14 @@ -- * MimeRender Instances -- | `encode`-instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @urlEncodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@)-instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} ToForm a => MimeRender FormUrlEncoded a where mimeRender _ = urlEncodeAsForm @@ -349,7 +349,7 @@ -- | @BC.pack@ instance MimeRender PlainText String where- mimeRender _ = BC.pack+ mimeRender _ = TextL.encodeUtf8 . TextL.pack -- | @id@ instance MimeRender OctetStream ByteString where@@ -363,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@@ -406,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
@@ -1,11 +1,30 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-}-module Servant.API.Description (Description, Summary) where+module Servant.API.Description (+ -- * Combinators+ Description,+ Summary,+ -- * Used as modifiers+ FoldDescription,+ FoldDescription',+ reflectDescription,+ ) where -import Data.Typeable (Typeable)-import GHC.TypeLits (Symbol)+import Data.Kind+ (Type)+import Data.Proxy+ (Proxy (..))+import Data.Typeable+ (Typeable)+import GHC.TypeLits+ (KnownSymbol, Symbol, symbolVal)+ -- | Add a short summary for (part of) API. -- -- Example:@@ -22,12 +41,38 @@ --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 list of modifiers to extract description as a type-level String.+--+-- >>> :kind! FoldDescription '[]+-- FoldDescription '[] :: Symbol+-- = ""+--+-- >>> :kind! FoldDescription '[Required, Description "foobar", Lenient]+-- FoldDescription '[Required, Description "foobar", Lenient] :: Symbol+-- = "foobar"+--+type FoldDescription mods = FoldDescription' "" mods++-- | Implementation of 'FoldDescription'.+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++-- | Reflect description to the term level.+--+-- >>> reflectDescription (Proxy :: Proxy '[Required, Description "foobar", Lenient])+-- "foobar"+--+reflectDescription :: forall mods. KnownSymbol (FoldDescription mods) => Proxy mods -> String+reflectDescription _ = symbolVal (Proxy :: Proxy (FoldDescription mods)) -- $setup -- >>> import Servant.API
src/Servant/API/Empty.hs view
@@ -2,9 +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,10 +1,11 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}++{-# LANGUAGE PolyKinds #-} module Servant.API.Experimental.Auth where -import Data.Typeable (Typeable)+import Data.Typeable+ (Typeable) -- | A generalized Authentication combinator. Use this if you have a -- non-standard authentication technique.
+ 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
@@ -0,0 +1,149 @@+{-# LANGUAGE ConstraintKinds #-}+{-# 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+-- define a record with field types prefixed by a parameter `route`:+--+-- @+-- data Routes route = Routes+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool+-- }+-- deriving ('Generic')+-- @+--+-- You can get a 'Proxy' of the server using+--+-- @+-- api :: Proxy (ToServantApi Routes)+-- api = genericApi (Proxy :: Proxy Routes)+-- @+--+-- Using 'genericApi' is better as it checks that instances exists,+-- i.e. you get better error messages than simply using 'Proxy' value.+--+-- __Note:__ in 0.14 series this module isn't re-exported from 'Servant.API'.+--+-- "Servant.API.Generic" is based on @servant-generic@ package by+-- [Patrick Chilton](https://github.com/chpatrick)+--+-- @since 0.14.1+module Servant.API.Generic (+ GenericMode (..),+ GenericServant,+ ToServant,+ toServant,+ fromServant,+ -- * AsApi+ AsApi,+ ToServantApi,+ genericApi,+ -- * Utility+ GServantProduct,+ -- * re-exports+ Generic (Rep),+ ) where++-- Based on servant-generic licensed under MIT License+--+-- Copyright (c) 2017 Patrick Chilton+--+-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to deal+-- in the Software without restriction, including without limitation the rights+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:+--+-- The above copyright notice and this permission notice shall be included in all+-- copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- 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+ ((:*:) (..), Generic (..), K1 (..), M1 (..))++import Servant.API.Alternative++-- | A constraint alias, for work with 'mode' and 'routes'.+type GenericServant routes mode = (GenericMode mode, Generic (routes mode), GServantProduct (Rep (routes mode)))++-- | A class with a type family that applies an appropriate type family to the @api@+-- parameter. For example, 'AsApi' will leave @api@ untouched, while+-- @'AsServerT' m@ will produce @'ServerT' api m@.+class GenericMode mode where+ type mode :- api :: Type++infixl 0 :-++-- | Turns a generic product type into a tree of `:<|>` combinators.+type ToServant routes mode = GToServant (Rep (routes mode))++type ToServantApi routes = ToServant routes AsApi++-- | See `ToServant`, but at value-level.+toServant+ :: GenericServant routes mode+ => routes mode -> ToServant routes mode+toServant = gtoServant . from++-- | Inverse of `toServant`.+--+-- This can be used to turn 'generated' values such as client functions into records.+--+-- You may need to provide a type signature for the /output/ type (your record type).+fromServant+ :: GenericServant routes mode+ => ToServant routes mode -> routes mode+fromServant = to . gfromServant++-- | A type that specifies that an API record contains an API definition. Only useful at type-level.+data AsApi+instance GenericMode AsApi where+ type AsApi :- api = api++-- | Get a 'Proxy' of an API type.+genericApi+ :: GenericServant routes AsApi+ => Proxy routes+ -> Proxy (ToServantApi routes)+genericApi _ = Proxy++-------------------------------------------------------------------------------+-- Class+-------------------------------------------------------------------------------+++class GServantProduct f where+ type GToServant f+ gtoServant :: f p -> GToServant f+ gfromServant :: GToServant f -> f p++instance GServantProduct f => GServantProduct (M1 i c f) where+ type GToServant (M1 i c f) = GToServant f+ gtoServant = gtoServant . unM1+ gfromServant = M1 . gfromServant++instance (GServantProduct l, GServantProduct r) => GServantProduct (l :*: r) where+ type GToServant (l :*: r) = GToServant l :<|> GToServant r+ gtoServant (l :*: r) = gtoServant l :<|> gtoServant r+ gfromServant (l :<|> r) = gfromServant l :*: gfromServant r++instance GServantProduct (K1 i c) where+ type GToServant (K1 i c) = c+ gtoServant = unK1+ gfromServant = K1
src/Servant/API/Header.hs view
@@ -1,16 +1,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Header (- Header(..),-) where+ Header, Header',+ ) where -import Data.ByteString (ByteString)-import Data.Typeable (Typeable)-import GHC.TypeLits (Symbol)+import Data.Kind+ (Type)+import Data.Typeable+ (Typeable)+import GHC.TypeLits+ (Symbol)+import Servant.API.Modifiers+ -- | Extract the given header's value as a value of type @a@.+-- I.e. header sent by client, parsed by server. -- -- Example: --@@ -18,10 +23,10 @@ -- >>> -- >>> -- GET /view-my-referer -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer-data Header (sym :: Symbol) a = Header a- | MissingHeader- | UndecodableHeader ByteString- deriving (Typeable, Eq, Show, Functor)+type Header = Header' '[Optional, Strict]++data Header' (mods :: [Type]) (sym :: Symbol) (a :: Type)+ deriving Typeable -- $setup -- >>> import Servant.API
+ 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/HttpVersion.hs view
@@ -3,7 +3,8 @@ HttpVersion(..) ) where -import Network.HTTP.Types (HttpVersion (..))+import Network.HTTP.Types+ (HttpVersion (..)) -- $httpversion --
− src/Servant/API/Internal/Test/ComprehensiveAPI.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}---- | This is a module containing an API with all `Servant.API` combinators. It--- is used for testing only (in particular, checking that instances exist for--- the core servant classes for each combinator), and should not be imported.-module Servant.API.Internal.Test.ComprehensiveAPI where--import Data.Proxy--import Servant.API--type GET = Get '[JSON] NoContent--type ComprehensiveAPI =- ComprehensiveAPIWithoutRaw :<|>- Raw--comprehensiveAPI :: Proxy ComprehensiveAPI-comprehensiveAPI = Proxy--type ComprehensiveAPIWithoutRaw =- GET :<|>- Get '[JSON] Int :<|>- Capture "foo" Int :> GET :<|>- Header "foo" Int :> GET :<|>- HttpVersion :> GET :<|>- IsSecure :> GET :<|>- QueryParam "foo" Int :> GET :<|>- QueryParams "foo" Int :> GET :<|>- QueryFlag "foo" :> GET :<|>- RemoteHost :> GET :<|>- ReqBody '[JSON] Int :> GET :<|>- Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>- "foo" :> GET :<|>- Vault :> GET :<|>- Verb 'POST 204 '[JSON] NoContent :<|>- Verb 'POST 204 '[JSON] Int :<|>- WithNamedContext "foo" '[] GET :<|>- CaptureAll "foo" Int :> GET :<|>- Summary "foo" :> GET :<|>- Description "foo" :> GET :<|>- EmptyAPI--comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw-comprehensiveAPIWithoutRaw = Proxy
src/Servant/API/IsSecure.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} module Servant.API.IsSecure ( -- $issecure IsSecure(..) ) where import Data.Typeable-import GHC.Generics (Generic)+ (Typeable)+import GHC.Generics+ (Generic) -- | Was this request made over an SSL connection? --
+ src/Servant/API/Modifiers.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+module Servant.API.Modifiers (+ -- * Required / optional argument+ Required, Optional,+ FoldRequired, FoldRequired',+ -- * Lenient / strict parsing+ Lenient, Strict,+ FoldLenient, FoldLenient',+ -- * Utilities+ RequiredArgument,+ foldRequiredArgument,+ unfoldRequiredArgument,+ RequestArgument,+ unfoldRequestArgument,+ ) where++import Data.Kind+ (Type)+import Data.Proxy+ (Proxy (..))+import Data.Singletons.Bool+ (SBool (..), SBoolI (..))+import Data.Text+ (Text)+import Data.Type.Bool+ (If)++-- | Required argument. Not wrapped.+data Required++-- | Optional argument. Wrapped in 'Maybe'.+data Optional++-- | Fold modifier list to decide whether argument is required.+--+-- >>> :kind! FoldRequired '[Required, Description "something"]+-- FoldRequired '[Required, Description "something"] :: Bool+-- = 'True+--+-- >>> :kind! FoldRequired '[Required, Optional]+-- FoldRequired '[Required, Optional] :: Bool+-- = 'False+--+-- >>> :kind! FoldRequired '[]+-- FoldRequired '[] :: Bool+-- = 'False+--+type FoldRequired mods = FoldRequired' 'False mods++-- | Implementation of 'FoldRequired'.+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+ FoldRequired' acc (mod ': mods) = FoldRequired' acc mods++-- | Leniently parsed argument, i.e. parsing never fail. Wrapped in @'Either' 'Text'@.+data Lenient++-- | Strictly parsed argument. Not wrapped.+data Strict++-- | Fold modifier list to decide whether argument should be parsed strictly or leniently.+--+-- >>> :kind! FoldLenient '[]+-- FoldLenient '[] :: Bool+-- = 'False+--+type FoldLenient mods = FoldLenient' 'False mods++-- | Implementation of 'FoldLenient'.+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+ FoldLenient' acc (mod ': mods) = FoldLenient' acc mods++-- | Helper type alias.+--+-- * 'Required' ↦ @a@+--+-- * 'Optional' ↦ @'Maybe' a@+--+type RequiredArgument mods a = If (FoldRequired mods) a (Maybe a)++-- | Fold a 'RequiredAgument' into a value+foldRequiredArgument+ :: forall mods a r. (SBoolI (FoldRequired mods))+ => Proxy mods+ -> (a -> r) -- ^ 'Required'+ -> (Maybe a -> r) -- ^ 'Optional'+ -> RequiredArgument mods a+ -> r+foldRequiredArgument _ f g mx =+ case (sbool :: SBool (FoldRequired mods), mx) of+ (STrue, x) -> f x+ (SFalse, x) -> g x++-- | Unfold a value into a 'RequiredArgument'.+unfoldRequiredArgument+ :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))+ => Proxy mods+ -> m (RequiredArgument mods a) -- ^ error when argument is required+ -> (Text -> m (RequiredArgument mods a)) -- ^ error when argument is strictly parsed+ -> Maybe (Either Text a) -- ^ value+ -> m (RequiredArgument mods a)+unfoldRequiredArgument _ errReq errSt mex =+ case (sbool :: SBool (FoldRequired mods), mex) of+ (STrue, Nothing) -> errReq+ (SFalse, Nothing) -> return Nothing+ (STrue, Just ex) -> either errSt return ex+ (SFalse, Just ex) -> either errSt (return . Just) ex++-- | Helper type alias.+--+-- By default argument is 'Optional' and 'Strict'.+--+-- * 'Required', 'Strict' ↦ @a@+--+-- * 'Required', 'Lenient' ↦ @'Either' 'Text' a@+--+-- * 'Optional', 'Strict' ↦ @'Maybe' a@+--+-- * 'Optional', 'Lenient' ↦ @'Maybe' ('Either' 'Text' a)@+--+type RequestArgument mods a =+ 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+ :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))+ => Proxy mods+ -> m (RequestArgument mods a) -- ^ error when argument is required+ -> (Text -> m (RequestArgument mods a)) -- ^ error when argument is strictly parsed+ -> Maybe (Either Text a) -- ^ value+ -> m (RequestArgument mods a)+unfoldRequestArgument _ errReq errSt mex =+ case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of+ (STrue, Nothing, _) -> errReq+ (SFalse, Nothing, _) -> return Nothing+ (STrue, Just ex, STrue) -> return ex+ (STrue, Just ex, SFalse) -> either errSt return ex+ (SFalse, Just ex, STrue) -> return (Just ex)+ (SFalse, Just ex, SFalse) -> either errSt (return . Just) ex++-- $setup+-- >>> import Servant.API
+ 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,12 +1,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-}+ {-# OPTIONS_HADDOCK not-home #-}-module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where+module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where -import Data.Typeable (Typeable)-import GHC.TypeLits (Symbol)+import Data.Kind+ (Type)+import Data.Typeable+ (Typeable)+import GHC.TypeLits+ (Symbol)+import Servant.API.Modifiers+ -- | Lookup the value associated to the @sym@ query string parameter -- and try to extract it as a value of type @a@. --@@ -14,7 +20,10 @@ -- -- >>> -- /books?author=<author name> -- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]-data QueryParam (sym :: Symbol) a+type QueryParam = QueryParam' '[Optional, Strict]++-- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise.+data QueryParam' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving Typeable -- | Lookup the values associated to the @sym@ query string parameter@@ -28,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
@@ -2,13 +2,19 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Raw where -import Data.Typeable (Typeable)+import Data.Typeable+ (Typeable)+ -- | Endpoint for plugging in your own Wai 'Application's. -- -- The given 'Application' will get the request as received by the server, potentially with -- 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/RemoteHost.hs view
@@ -5,6 +5,7 @@ ) where import Data.Typeable+ (Typeable) -- | Provides access to the host or IP address -- from which the HTTP request was sent.
src/Servant/API/ReqBody.hs view
@@ -2,16 +2,28 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-}-module Servant.API.ReqBody where+module Servant.API.ReqBody (+ ReqBody, ReqBody',+ ) where -import Data.Typeable (Typeable)+import Data.Kind+ (Type)+import Data.Typeable+ (Typeable)+import Servant.API.Modifiers+ -- | Extract the request body as a value of type @a@. -- -- Example: -- -- >>> -- POST /books -- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book-data ReqBody (contentTypes :: [*]) a+type ReqBody = ReqBody' '[Required, Strict]++-- |+--+-- /Note:/ 'ReqBody'' is always 'Required'.+data ReqBody' (mods :: [Type]) (contentTypes :: [Type]) (a :: Type) deriving (Typeable) -- $setup
src/Servant/API/ResponseHeaders.hs view
@@ -1,20 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# 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 #-} -#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int@@ -23,26 +9,45 @@ -- example above). module Servant.API.ResponseHeaders ( Headers(..)+ , ResponseHeader (..) , AddHeader , addHeader+ , addHeader' , noHeader+ , noHeader'+ , HasResponseHeader+ , lookupResponseHeader , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders)+ , GetHeaders' , HeaderValMap , HList(..) ) where -import Data.ByteString.Char8 as BS (pack, unlines, init)-import Web.HttpApiData (ToHttpApiData, toHeader,- FromHttpApiData, parseHeader)-import qualified Data.CaseInsensitive as CI+import Control.DeepSeq+ (NFData (..))+import Data.ByteString.Char8 as BS+ (ByteString, pack)+import qualified Data.CaseInsensitive as CI+import Data.Kind+ (Type)+import qualified Data.List as L import Data.Proxy-import GHC.TypeLits (KnownSymbol, symbolVal)-import qualified Network.HTTP.Types.Header as HTTP+import Data.Typeable+ (Typeable)+import GHC.TypeLits+ (KnownSymbol, Symbol, symbolVal)+import qualified Network.HTTP.Types.Header as HTTP+import Web.HttpApiData+ (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) -import Servant.API.Header (Header (..))-import Prelude ()-import Prelude.Compat+import Servant.API.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'.@@ -52,83 +57,139 @@ -- ^ 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 :: Header 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+instance {-# OVERLAPPING #-} BuildHeadersTo '[] where buildHeadersTo _ = HNil -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+-- 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' 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] -instance OVERLAPPING_ GetHeaders (HList '[]) where- getHeaders _ = []+-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance+class GetHeadersFromHList hs where+ getHeadersFromHList :: HList hs -> [HTTP.Header] -instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) )- => GetHeaders (HList (Header h x ': xs)) where- getHeaders hdrs = case hdrs of- Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest- UndecodableHeader h `HCons` rest -> (headerName, h) :getHeaders rest- MissingHeader `HCons` rest -> getHeaders rest- where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)+instance GetHeadersFromHList hs => GetHeaders (HList hs) where+ getHeaders = getHeadersFromHList -instance OVERLAPPING_ GetHeaders (Headers '[] a) where- getHeaders _ = []+instance GetHeadersFromHList '[] where+ getHeadersFromHList _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v )- => GetHeaders (Headers (Header h v ': rest) a) where- getHeaders hs = getHeaders $ getHeadersHList hs+instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)+ => GetHeadersFromHList (Header' mods h x ': xs)+ where+ getHeadersFromHList hdrs = case hdrs of+ Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest+ UndecodableHeader h `HCons` rest -> (headerName, h) : getHeadersFromHList rest+ MissingHeader `HCons` rest -> getHeadersFromHList rest+ where+ headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) --- * Adding+-- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance+class GetHeaders' hs where+ getHeaders' :: Headers hs a -> [HTTP.Header] --- 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- addOptionalHeader :: Header h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times+instance GetHeaders' hs => GetHeaders (Headers hs a) where+ getHeaders = getHeaders' +-- | This instance is an optimisation+instance GetHeaders' '[] where+ getHeaders' _ = [] -instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )- => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where+instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)+ => GetHeaders' (Header' mods h v ': rest)+ where+ getHeaders' hs = getHeadersFromHList $ getHeadersHList hs++-- * Adding headers++-- We need all these fundeps to save type inference+class AddHeader (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 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@@ -142,18 +203,62 @@ -- 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' mods h a ': rest) where+ hlistLookupHeader (HCons ha _) = ha++instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where+ hlistLookupHeader (HCons _ hs) = hlistLookupHeader hs++-- | Look up a specific ResponseHeader,+-- without having to know what position it is in the HList.+--+-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String+-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String+-- >>> lookupResponseHeader example2 :: ResponseHeader "someheader" Int+-- Header 5+--+-- >>> lookupResponseHeader example2 :: ResponseHeader "1st" Bool+-- Header True+--+-- Usage of this function relies on an explicit type annotation of the header to be looked up.+-- This can be done with type annotations on the result, or with an explicit type application.+-- In this example, the type of header value is determined by the type-inference,+-- we only specify the name of the header:+--+-- >>> :set -XTypeApplications+-- >>> case lookupResponseHeader @"1st" example2 of { Header b -> b ; _ -> False }+-- True+--+-- @since 0.15+--+lookupResponseHeader :: (HasResponseHeader h a headers)+ => Headers headers r -> ResponseHeader h a+lookupResponseHeader = hlistLookupHeader . getHeadersHList+ -- $setup+-- >>> :set -XFlexibleContexts -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text
+ 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
@@ -0,0 +1,236 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK not-home #-}++module Servant.API.Stream (+ Stream,+ StreamGet,+ StreamPost,+ StreamBody,+ StreamBody',+ -- * Source+ --+ -- | 'SourceIO' are equivalent to some *source* in streaming libraries.+ SourceIO,+ ToSourceIO (..),+ FromSourceIO (..),+ -- ** Auxiliary classes+ SourceToSourceIO (..),+ -- * Framing+ FramingRender (..),+ FramingUnrender (..),+ -- ** Strategies+ NoFraming,+ NewlineFraming,+ NetstringFraming,+ ) where+++import Control.Applicative+ ((<|>))+import Control.Monad.IO.Class+ (MonadIO (..))+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.Kind+ (Type)+import Data.List.NonEmpty+ (NonEmpty (..))+import Data.Proxy+ (Proxy)+import Data.Typeable+ (Typeable)+import GHC.Generics+ (Generic)+import GHC.TypeLits+ (Nat)+import Network.HTTP.Types.Method+ (StdMethod (..))+import Servant.Types.SourceT++-- | A Stream endpoint for a given method emits a stream of encoded values at a+-- given @Content-Type@, delimited by a @framing@ strategy.+-- Type synonyms are provided for standard methods.+--+data Stream (method :: k1) (status :: Nat) (framing :: Type) (contentType :: Type) (a :: Type)+ deriving (Typeable, Generic)++type StreamGet = Stream 'GET 200+type StreamPost = Stream 'POST 200++-- | A stream request body.+type StreamBody = StreamBody' '[]++data StreamBody' (mods :: [Type]) (framing :: Type) (contentType :: Type) (a :: Type)+ deriving (Typeable, Generic)++-------------------------------------------------------------------------------+-- Sources+-------------------------------------------------------------------------------++-- | Stream endpoints may be implemented as producing a @'SourceIO' chunk@.+--+-- Clients reading from streaming endpoints can be implemented as consuming a+-- @'SourceIO' chunk@.+--+type SourceIO = SourceT IO++-- | 'ToSourceIO' is intended to be implemented for types such as Conduit, Pipe,+-- etc. By implementing this class, all such streaming abstractions can be used+-- directly as endpoints.+class ToSourceIO chunk a | a -> chunk where+ toSourceIO :: a -> SourceIO chunk++-- | Auxiliary class for @'ToSourceIO' x ('SourceT' m x)@ instance.+class SourceToSourceIO m where+ sourceToSourceIO :: SourceT m a -> SourceT IO a++instance SourceToSourceIO IO where+ sourceToSourceIO = id++-- | Relax to use auxiliary class, have m+instance SourceToSourceIO m => ToSourceIO chunk (SourceT m chunk) where+ toSourceIO = sourceToSourceIO++instance ToSourceIO a (NonEmpty a) where+ toSourceIO (x :| xs) = fromStepT (Yield x (foldr Yield Stop xs))++instance ToSourceIO a [a] where+ toSourceIO = source++-- | 'FromSourceIO' is intended to be implemented for types such as Conduit,+-- 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 -> IO a++instance MonadIO m => FromSourceIO a (SourceT m a) where+ fromSourceIO = return . sourceFromSourceIO++sourceFromSourceIO :: forall m a. MonadIO m => SourceT IO a -> SourceT m a+sourceFromSourceIO src =+ SourceT $ \k ->+ k $ Effect $ liftIO $ unSourceT src (return . go)+ where+ go :: StepT IO a -> StepT m a+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ go (Effect ms) = Effect (liftIO (fmap go ms))+ go (Yield x s) = Yield x (go s)++-- This fires e.g. in Client.lhs+-- {-# OPTIONS_GHC -ddump-simpl -ddump-rule-firings -ddump-to-file #-}+{-# NOINLINE [2] sourceFromSourceIO #-}+{-# RULES "sourceFromSourceIO @IO" sourceFromSourceIO = id :: SourceT IO a -> SourceT IO a #-}++-------------------------------------------------------------------------------+-- Framing+-------------------------------------------------------------------------------++-- | The 'FramingRender' class provides the logic for emitting a framing strategy.+-- The strategy transforms a @'SourceT' m a@ into @'SourceT' m 'LBS.ByteString'@,+-- therefore it can prepend, append and intercalate /framing/ structure+-- around chunks.+--+-- /Note:/ as the @'Monad' m@ is generic, this is pure transformation.+--+class FramingRender strategy where+ framingRender :: Monad m => Proxy strategy -> (a -> LBS.ByteString) -> SourceT m a -> SourceT m LBS.ByteString++-- | The 'FramingUnrender' class provides the logic for parsing a framing+-- strategy.+class FramingUnrender strategy where+ framingUnrender :: Monad m => Proxy strategy -> (LBS.ByteString -> Either String a) -> SourceT m BS.ByteString -> SourceT m a++-------------------------------------------------------------------------------+-- NoFraming+-------------------------------------------------------------------------------++-- | A framing strategy that does not do any framing at all, it just passes the+-- input data This will be used most of the time with binary data, such as+-- files+data NoFraming++instance FramingRender NoFraming where+ framingRender _ = fmap++-- | As 'NoFraming' doesn't have frame separators, we take the chunks+-- as given and try to convert them one by one.+--+-- That works well when @a@ is a 'ByteString'.+instance FramingUnrender NoFraming where+ framingUnrender _ f = mapStepT go+ where+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ go (Effect ms) = Effect (fmap go ms)+ go (Yield x s) = case f (LBS.fromStrict x) of+ Right y -> Yield y (go s)+ Left err -> Error err++-------------------------------------------------------------------------------+-- NewlineFraming+-------------------------------------------------------------------------------++-- | A simple framing strategy that has no header, and inserts a+-- newline character after each frame. This assumes that it is used with a+-- Content-Type that encodes without newlines (e.g. JSON).+data NewlineFraming++instance FramingRender NewlineFraming where+ framingRender _ f = fmap (\x -> f x <> "\n")++instance FramingUnrender NewlineFraming where+ framingUnrender _ f = transformWithAtto $ do+ bs <- A.takeWhile (/= 10)+ () <$ A.word8 10 <|> A.endOfInput+ either fail pure (f (LBS.fromStrict bs))++-------------------------------------------------------------------------------+-- NetstringFraming+-------------------------------------------------------------------------------++-- | The netstring framing strategy as defined by djb:+-- <http://cr.yp.to/proto/netstrings.txt>+--+-- Any string of 8-bit bytes may be encoded as @[len]":"[string]","@. Here+-- @[string]@ is the string and @[len]@ is a nonempty sequence of ASCII digits+-- giving the length of @[string]@ in decimal. The ASCII digits are @<30>@ for+-- 0, @<31>@ for 1, and so on up through @<39>@ for 9. Extra zeros at the front+-- of @[len]@ are prohibited: @[len]@ begins with @<30>@ exactly when+-- @[string]@ is empty.+--+-- For example, the string @"hello world!"@ is encoded as+-- @<31 32 3a 68 65 6c 6c 6f 20 77 6f 72 6c 64 21 2c>@,+-- i.e., @"12:hello world!,"@.+-- The empty string is encoded as @"0:,"@.+--+data NetstringFraming++instance FramingRender NetstringFraming where+ framingRender _ f = fmap $ \x ->+ let bs = f x+ in LBS8.pack (show (LBS8.length bs)) <> ":" <> bs <> ","++instance FramingUnrender NetstringFraming where+ framingUnrender _ f = transformWithAtto $ do+ len <- A8.decimal+ _ <- A8.char ':'+ bs <- A.take len+ _ <- A8.char ','+ either fail pure (f (LBS.fromStrict bs))
src/Servant/API/Sub.hs view
@@ -4,7 +4,10 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Sub ((:>)) where -import Data.Typeable (Typeable)+import Data.Kind+ (Type)+import Data.Typeable+ (Typeable) -- | The contained API (second argument) can be found under @("/" ++ path)@ -- (path being the first argument).@@ -14,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,23 +45,39 @@ -- ** Logic Or, And,- -- * Custom type errors- -- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class,- -- which cannot be instantiated.+ -- ** Fragment+ FragmentUnique,+ AtMostOneFragment ) where -import GHC.Exts (Constraint)-import Servant.API.Alternative (type (:<|>))-import Servant.API.Capture (Capture, CaptureAll)-import Servant.API.Header (Header)-import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)-import Servant.API.ReqBody (ReqBody)-import Servant.API.Sub (type (:>))-import Servant.API.Verbs (Verb)-#if MIN_VERSION_base(4,9,0)-import GHC.TypeLits (TypeError, ErrorMessage(..))-#endif+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')+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) @@ -96,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@@ -116,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@@ -124,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@.@@ -136,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.@@ -159,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@. --@@ -174,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 = ()@@ -213,47 +237,75 @@ type family ElemGo e es orig :: Constraint where ElemGo x (x ': xs) orig = () ElemGo y (x ': xs) orig = ElemGo y xs orig-#if MIN_VERSION_base(4,9,0) -- Note [Custom Errors] ElemGo x '[] orig = TypeError ('ShowType x ':<>: 'Text " expected in list " ':<>: 'ShowType orig)-#else- ElemGo x '[] orig = ElemNotFoundIn x orig-#endif -- ** 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 () () = () --- * Custom type errors--#if !MIN_VERSION_base(4,9,0)-class ElemNotFoundIn val list-#endif- {- Note [Custom Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We might try to factor these our more cleanly, but the type synonyms and type 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@@ -261,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/Vault.hs view
@@ -3,7 +3,8 @@ Vault ) where -import Data.Vault.Lazy (Vault)+import Data.Vault.Lazy+ (Vault) -- $vault --
src/Servant/API/Verbs.hs view
@@ -1,31 +1,42 @@ {-# 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.Typeable (Typeable)-import Data.Proxy (Proxy)-import GHC.Generics (Generic)-import GHC.TypeLits (Nat)-import Network.HTTP.Types.Method (Method, StdMethod (..),- methodDelete, methodGet, methodHead,- methodPatch, methodPost, methodPut,- methodTrace, methodConnect,- methodOptions)+import Data.Kind+ (Type)+import Data.Proxy+ (Proxy)+import Data.Typeable+ (Typeable)+import GHC.Generics+ (Generic)+import GHC.TypeLits+ (Nat)+import Network.HTTP.Types.Method+ (Method, StdMethod (..), methodConnect, methodDelete,+ methodGet, methodHead, methodOptions, methodPatch, methodPost,+ methodPut, methodTrace) -- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For -- convenience, type synonyms for each verb with a 200 response code are -- 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.@@ -53,14 +64,17 @@ -- Indicates that a new resource has been created. The URI corresponding to the -- resource should be given in the @Location@ header field. --+-- If the operation is idempotent, use 'PutCreated'. If not, use 'PostCreated'+-- -- If the resource cannot be created immediately, use 'PostAccepted'. ----- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header+-- Consider using 'Servant.Links.safeLink' for the @Location@ header -- field. -- | 'POST' with 201 status code.--- type PostCreated = Verb 'POST 201+-- | 'PUT' with 201 status code.+type PutCreated = Verb 'PUT 201 -- ** 202 Accepted@@ -107,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
@@ -1,9 +1,11 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} module Servant.API.WithNamedContext where -import GHC.TypeLits+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
@@ -0,0 +1,711 @@+{-# 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 -XPolyKinds+-- >>> import Servant.API+-- >>> import Servant.Links+-- >>> import Web.HttpApiData (toUrlPiece)+-- >>> import Data.Proxy+-- >>>+-- >>> type Hello = "hello" :> Get '[JSON] Int+-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent+-- >>> type API = Hello :<|> Bye+-- >>> let api = Proxy :: Proxy API+--+-- It is possible to generate links that are guaranteed to be within 'API' with+-- 'safeLink'. The first argument to 'safeLink' is a type representing the API+-- you would like to restrict links to. The second argument is the destination+-- endpoint you would like the link to point to, this will need to end with a+-- verb like GET or POST. Further arguments may be required depending on the+-- type of the endpoint. If everything lines up you will get a 'Link' out the+-- other end.+--+-- You may omit 'QueryParam's and the like should you not want to provide them,+-- but types which form part of the URL path like 'Capture' must be included.+-- The reason you may want to omit 'QueryParam's is that safeLink is a bit+-- magical: if parameters are included that could take input it will return a+-- function that accepts that input and generates a link. This is best shown+-- with an example. Here, a link is generated with no parameters:+--+-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)+-- >>> toUrlPiece (safeLink api hello :: Link)+-- "hello"+--+-- If the API has an endpoint with parameters then we can generate links with+-- or without those:+--+-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")+-- "bye?name=Hubert"+--+-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)+-- >>> toUrlPiece $ safeLink api without+-- "bye"+--+-- 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:+--+-- >>> :set -XConstraintKinds+-- >>> :{+-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)+-- >>> => Proxy endpoint -> MkLink endpoint Link+-- >>> apiLink = safeLink api+-- >>> :}+--+-- `safeLink'` allows you to specialise the output:+--+-- >>> safeLink' toUrlPiece api without+-- "bye"+--+-- >>> :{+-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)+-- >>> => Proxy endpoint -> MkLink endpoint Text+-- >>> apiTextLink = safeLink' toUrlPiece api+-- >>> :}+--+-- >>> apiTextLink without+-- "bye"+--+-- Attempting to construct a link to an endpoint that does not exist in api+-- will result in a type error like this:+--+-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)+-- >>> safeLink api bad_link+-- ...+-- ...Could not ...+-- ...+--+-- This error is essentially saying that the type family couldn't find+-- bad_link under api after trying the open (but empty) type family+-- `IsElem'` as a last resort.+--+-- @since 0.14.1+module Servant.Links (+ module Servant.API.TypeLevel,++ -- * Building and using safe links+ --+ -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.+ safeLink+ , safeLink'+ , allLinks+ , allLinks'+ , URI(..)+ -- * Generics+ , AsLink+ , fieldLink+ , fieldLink'+ , allFieldLinks+ , allFieldLinks'+ -- * Adding custom types+ , HasLink(..)+ , Link+ , linkURI+ , linkURI'+ , LinkArrayElementStyle (..)+ -- ** Link accessors+ , Param (..)+ , linkSegments+ , linkQueryParams+ , linkFragment+ , addQueryParam+) where++import Data.Kind+ (Type)+import qualified Data.List as List+import Data.Constraint+import Data.Proxy+ (Proxy (..))+import Data.Singletons.Bool+ (SBool (..), SBoolI (..))+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import Data.Type.Bool+ (If)+import GHC.TypeLits+ (KnownSymbol, TypeError, symbolVal)+import Network.URI+ (URI (..), escapeURIString, isUnreserved)++import Servant.API.Alternative+ ((:<|>) ((:<|>)))+import Servant.API.BasicAuth+ (BasicAuth)+import Servant.API.Capture+ (Capture', CaptureAll)+import Servant.API.Description+ (Description, Summary)+import Servant.API.Empty+ (EmptyAPI (..))+import Servant.API.Experimental.Auth+ (AuthProtect)+import Servant.API.Fragment+ (Fragment)+import Servant.API.Generic+import Servant.API.Header+ (Header')+import Servant.API.HttpVersion+ (HttpVersion)+import Servant.API.IsSecure+ (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, RawM)+import Servant.API.RemoteHost+ (RemoteHost)+import Servant.API.ReqBody+ (ReqBody')+import Servant.API.Stream+ (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, 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 . escape++getEscaped :: Escaped -> String+getEscaped (Escaped s) = s++instance Show Escaped where+ showsPrec d (Escaped s) = showsPrec d s+ show (Escaped s) = show s++linkSegments :: Link -> [String]+linkSegments = map getEscaped . _segments++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 ++ uriFragment uri++-- | Query parameter.+data Param+ = SingleParam String Text.Text+ | ArrayElemParam String Text.Text+ | FlagParam String+ deriving Show++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+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)+-- something+--+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x[]=1&x[]=2&x[]=3+--+-- >>> type API = "foo/bar" :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)+-- foo%2Fbar+--+-- >>> 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 = [], _fragment = Nothing}+--+-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"+-- abc/test%40example.com+--+linkURI :: Link -> URI+linkURI = linkURI' LinkArrayElementBracket++-- | How to encode array query elements.+data LinkArrayElementStyle+ = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@+ | LinkArrayElementPlain -- ^ @foo=1&foo=2@+ deriving (Eq, Ord, Show, Enum, Bounded)++-- | Configurable 'linkURI'.+--+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int+-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x[]=1&x[]=2&x[]=3+--+-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x=1&x=2&x=3+--+linkURI' :: LinkArrayElementStyle -> Link -> URI+linkURI' addBrackets (Link segments q_params mfragment) =+ URI mempty -- No scheme (relative)+ Nothing -- Or authority (relative)+ (List.intercalate "/" $ map getEscaped segments)+ (makeQueries q_params)+ (makeFragment mfragment)+ where+ makeQueries :: [Param] -> String+ makeQueries [] = ""+ makeQueries 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 -> "="++escape :: String -> String+escape = escapeURIString isUnreserved++-- | Create a valid (by construction) relative URI with query params.+--+-- This function will only typecheck if `endpoint` is part of the API `api`+safeLink+ :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)+ => 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 Link+safeLink = safeLink' id++-- | More general 'safeLink'.+--+safeLink'+ :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)+ => (Link -> a)+ -> 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 mempty)++-- | Create all links in an API.+--+-- Note that the @api@ type must be restricted to the endpoints that have+-- valid links to them.+--+-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double+-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)+-- >>> :t fooLink+-- fooLink :: Text -> Link+-- >>> :t barLink+-- barLink :: Int -> Link+--+-- 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 :: Type+-- = Char -> (Int -> Link) :<|> (Double -> Link)+allLinks+ :: forall api. HasLink api+ => Proxy api+ -> MkLink api Link+allLinks = allLinks' id++-- | More general 'allLinks'. See `safeLink'`.+allLinks'+ :: forall api a. HasLink api+ => (Link -> a)+ -> Proxy api+ -> MkLink api a+allLinks' toA api = toLink toA api (Link mempty mempty mempty)++-------------------------------------------------------------------------------+-- Generics+-------------------------------------------------------------------------------++-- | Given an API record field, create a link for that route. Only the field's+-- type is used.+--+-- @+-- data Record route = Record+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool+-- }+-- deriving ('Generic')+--+-- getLink :: Int -> Link+-- getLink = 'fieldLink' _get+-- @+--+-- @since 0.14.1+fieldLink+ :: ( IsElem endpoint (ToServantApi routes)+ , HasLink endpoint+ , GenericServant routes AsApi+ )+ =>(routes AsApi -> endpoint)+ -> MkLink endpoint Link+fieldLink = fieldLink' id++-- | More general version of 'fieldLink'+--+-- @since 0.14.1+fieldLink'+ :: forall routes endpoint a.+ ( IsElem endpoint (ToServantApi routes)+ , HasLink endpoint+ , GenericServant routes AsApi+ )+ =>(Link -> a)+ -> (routes AsApi -> endpoint)+ -> MkLink endpoint a+fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)++-- | A type that specifies that an API record contains a set of links.+--+-- @since 0.14.1+data AsLink (a :: Type)+instance GenericMode (AsLink a) where+ type (AsLink a) :- api = MkLink api a++-- | Get all links as a record.+--+-- @since 0.14.1+allFieldLinks+ :: ( HasLink (ToServantApi routes)+ , GenericServant routes (AsLink Link)+ , ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link+ )+ => routes (AsLink Link)+allFieldLinks = allFieldLinks' id++-- | More general version of 'allFieldLinks'.+--+-- @since 0.14.1+allFieldLinks'+ :: forall routes a.+ ( HasLink (ToServantApi routes)+ , GenericServant routes (AsLink a)+ , ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a+ )+ => (Link -> a)+ -> routes (AsLink a)+allFieldLinks' toA+ = fromServant+ $ allLinks' toA (Proxy :: Proxy (ToServantApi routes))++-------------------------------------------------------------------------------+-- HasLink+-------------------------------------------------------------------------------++-- | Construct a toLink for an endpoint.+class HasLink endpoint where+ type MkLink endpoint (a :: Type)+ toLink+ :: (Link -> a)+ -> Proxy endpoint -- ^ The API endpoint you would like to point to+ -> Link+ -> MkLink endpoint a++-- Naked symbol instance+instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where+ type MkLink (sym :> sub) a = MkLink sub a+ toLink toA _ =+ toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)+ where+ seg = symbolVal (Proxy :: Proxy sym)++-- QueryParam instances+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))+ => HasLink (QueryParam' mods sym v :> sub)+ where+ type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a+ toLink toA _ l mv =+ toLink toA (Proxy :: Proxy sub) $+ case sbool :: SBool (FoldRequired mods) of+ STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l+ SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l+ where+ k :: String+ k = symbolVal (Proxy :: Proxy sym)++instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)+ => HasLink (QueryParams sym v :> sub)+ where+ type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a+ toLink toA _ l =+ toLink toA (Proxy :: Proxy sub) .+ List.foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l+ where+ k = symbolVal (Proxy :: Proxy sym)++instance (KnownSymbol sym, HasLink sub)+ => HasLink (QueryFlag sym :> sub)+ where+ type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a+ toLink toA _ l False =+ toLink toA (Proxy :: Proxy sub) l+ toLink toA _ l True =+ toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l+ where+ k = symbolVal (Proxy :: Proxy sym)++-- :<|> instance - Generate all links at once+instance (HasLink a, HasLink b) => HasLink (a :<|> b) where+ type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r+ toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l++-- Misc instances+instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where+ type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r+ toLink toA _ = toLink toA (Proxy :: Proxy sub)++instance HasLink sub => HasLink (StreamBody' mods framing ct a :> sub) where+ type MkLink (StreamBody' mods framing ct a :> sub) r = MkLink sub r+ toLink toA _ = toLink toA (Proxy :: Proxy sub)++instance (ToHttpApiData v, HasLink sub)+ => HasLink (Capture' mods sym v :> sub)+ where+ type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a+ toLink toA _ l v =+ toLink toA (Proxy :: Proxy sub) $+ addSegment (escaped . Text.unpack $ toUrlPiece v) l++instance (ToHttpApiData v, HasLink sub)+ => HasLink (CaptureAll sym v :> sub)+ where+ type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a+ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $+ List.foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs++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)++instance HasLink sub => HasLink (Vault :> sub) where+ type MkLink (Vault :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (Description s :> sub) where+ type MkLink (Description s :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (Summary s :> sub) where+ type MkLink (Summary s :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (HttpVersion :> sub) where+ type MkLink (HttpVersion:> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (IsSecure :> sub) where+ type MkLink (IsSecure :> sub) a = MkLink sub a+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink sub => HasLink (WithNamedContext name context sub) where+ 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)++instance HasLink sub => HasLink (BasicAuth realm a :> sub) where+ type MkLink (BasicAuth realm a :> sub) r = MkLink sub r+ toLink = simpleToLink (Proxy :: Proxy sub)++instance HasLink EmptyAPI where+ type MkLink EmptyAPI a = EmptyAPI+ toLink _ _ _ = EmptyAPI++-- Verb (terminal) instances+instance HasLink (Verb m s ct a) where+ 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)++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.+ (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)+ => Proxy sub+ -> (Link -> a)+ -> Proxy (combinator :> sub)+ -> Link+ -> MkLink (combinator :> sub) a+simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)+++-- $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
@@ -0,0 +1,81 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++-- | This is a module containing an API with all `Servant.API` combinators. It+-- is used for testing only (in particular, checking that instances exist for+-- the core servant classes for each combinator).+module Servant.Test.ComprehensiveAPI where++import Data.Proxy+ (Proxy (..))+import Servant.API+import Servant.Types.SourceT+ (SourceT)++type GET = Get '[JSON] NoContent++type ComprehensiveAPI =+ ComprehensiveAPIWithoutStreamingOrRaw'+ (EmptyEndpoint :<|> StreamingEndpoint :<|> RawEndpoint)++type RawEndpoint =+ "raw" :> Raw++type StreamingEndpoint =+ "streaming" :> StreamBody' '[Description "netstring"] NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int)++type EmptyEndpoint =+ "empty-api" :> EmptyAPI++comprehensiveAPI :: Proxy ComprehensiveAPI+comprehensiveAPI = Proxy++type ComprehensiveAPIWithoutRaw =+ ComprehensiveAPIWithoutStreamingOrRaw'+ (EmptyEndpoint :<|> StreamingEndpoint)++comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw+comprehensiveAPIWithoutRaw = Proxy++type ComprehensiveAPIWithoutStreaming =+ ComprehensiveAPIWithoutStreamingOrRaw'+ (EmptyEndpoint :<|> RawEndpoint)++comprehensiveAPIWithoutStreaming :: Proxy ComprehensiveAPIWithoutStreaming+comprehensiveAPIWithoutStreaming = Proxy++-- | @:: API -> API@, so we have linear structure of the API.+type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =+ GET+ :<|> "get-int" :> Get '[JSON] Int+ :<|> "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+ :<|> "is-secure" :> IsSecure :> GET+ :<|> "param" :> QueryParam "foo" Int :> GET+ :<|> "param-lenient" :> QueryParam' '[Required, Lenient] "bar" Int :> GET+ :<|> "params" :> QueryParams "foo" Int :> GET+ :<|> "flag" :> QueryFlag "foo" :> GET+ :<|> "remote-host" :> RemoteHost :> GET+ :<|> "req-body" :> ReqBody '[JSON] Int :> GET+ :<|> "req-body-lenient" :> ReqBody' '[Lenient] '[JSON] Int :> GET+ :<|> "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent)+ :<|> "foo" :> GET+ :<|> "vault" :> Vault :> GET+ :<|> "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++comprehensiveAPIWithoutStreamingOrRaw :: Proxy ComprehensiveAPIWithoutStreamingOrRaw+comprehensiveAPIWithoutStreamingOrRaw = Proxy
+ 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
@@ -0,0 +1,399 @@+{-# LANGUAGE CPP #-}+module Servant.Types.SourceT where++import Control.Monad.Except+ (ExceptT (..), runExceptT, throwError)+import Control.Monad.Morph+ (MFunctor (..))+import Control.Monad.Trans.Class+ (MonadTrans (..))+import qualified Data.Attoparsec.ByteString as A+import qualified Data.ByteString as BS+import Data.Functor.Classes+ (Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)+import Data.Functor.Identity+ (Identity (..))+import Prelude hiding (readFile)+import System.IO+ (Handle, IOMode (..), withFile)+import qualified Test.QuickCheck as QC++-- $setup+-- >>> :set -XNoOverloadedStrings+-- >>> import Data.String (fromString)+-- >>> import Control.Monad.Except (runExcept)+-- >>> import Data.Foldable (toList)+-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8++-- | This is CPSised ListT.+--+-- @since 0.15+--+newtype SourceT m a = SourceT+ { unSourceT :: forall b. (StepT m a -> m b) -> m b+ }++mapStepT :: (StepT m a -> StepT m b) -> SourceT m a -> SourceT m b+mapStepT f (SourceT m) = SourceT $ \k -> m (k . f)+{-# INLINE mapStepT #-}++-- | @ListT@ with additional constructors.+--+-- @since 0.15+--+data StepT m a+ = Stop+ | Error String -- we can this argument configurable.+ | Skip (StepT m a) -- Note: not sure about this constructor+ | Yield a (StepT m a)+ | Effect (m (StepT m a))+ deriving Functor++-- | Create 'SourceT' from 'Step'.+--+-- /Note:/ often enough you want to use 'SourceT' directly.+fromStepT :: StepT m a -> SourceT m a+fromStepT s = SourceT ($ s)++-------------------------------------------------------------------------------+-- SourceT instances+-------------------------------------------------------------------------------++instance Functor m => Functor (SourceT m) where+ fmap f = mapStepT (fmap f)++-- | >>> toList (source [1::Int .. 10])+-- [1,2,3,4,5,6,7,8,9,10]+--+instance Identity ~ m => Foldable (SourceT m) where+ foldr f z (SourceT m) = foldr f z (runIdentity (m Identity))++instance (Applicative m, Show1 m) => Show1 (SourceT m) where+ liftShowsPrec sp sl d (SourceT m) = showsUnaryWith+ (liftShowsPrec sp sl)+ "fromStepT" d (Effect (m pure'))+ where+ pure' (Effect s) = s+ pure' s = pure s++instance (Applicative m, Show1 m, Show a) => Show (SourceT m a) where+ showsPrec = showsPrec1++-- | >>> hoist (Just . runIdentity) (source [1..3]) :: SourceT Maybe Int+-- 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 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++-- An example of above instance. Not doctested because it's volatile.+--+-- >>> import Test.QuickCheck as QC+-- >>> import Test.QuickCheck.Gen as QC+-- >>> import Test.QuickCheck.Random as QC+-- >>> let generate (QC.MkGen g) = g (QC.mkQCGen 44) 10+--+-- >>> generate (arbitrary :: QC.Gen (SourceT Identity Int))+-- fromStepT (Effect (Identity (Yield (-10) (Yield 3 (Skip (Yield 1 Stop))))))++-------------------------------------------------------------------------------+-- StepT instances+-------------------------------------------------------------------------------++instance Identity ~ m => Foldable (StepT m) where+ foldr f z = go where+ go Stop = z+ go (Error _) = z+ go (Skip s) = go s+ go (Yield a s) = f a (go s)+ go (Effect (Identity s)) = go s++instance (Applicative m, Show1 m) => Show1 (StepT m) where+ liftShowsPrec sp sl = go where+ go _ Stop = showString "Stop"+ go d (Skip s) = showsUnaryWith+ go+ "Skip" d s+ go d (Error err) = showsUnaryWith+ showsPrec+ "Error" d err+ go d (Effect ms) = showsUnaryWith+ (liftShowsPrec go goList)+ "Effect" d ms+ go d (Yield x s) = showsBinaryWith+ sp go+ "Yield" d x s++ goList = liftShowList sp sl++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+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ 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+ arb n | n <= 0 = pure Stop+ | otherwise = QC.frequency+ [ (1, pure Stop)+ , (1, Skip <$> arb')+ , (1, Effect . pure <$> arb')+ , (8, Yield <$> QC.arbitrary <*> arb')+ ]+ where+ arb' = arb (n - 1)++ shrink Stop = []+ shrink (Error _) = [Stop]+ shrink (Skip s) = [s]+ shrink (Effect _) = []+ shrink (Yield x s) =+ [ Yield x' s | x' <- QC.shrink x ] +++ [ Yield x s' | s' <- QC.shrink s ]++-------------------------------------------------------------------------------+-- Operations+-------------------------------------------------------------------------------++-- | Create pure 'SourceT'.+--+-- >>> source "foo" :: SourceT Identity Char+-- fromStepT (Effect (Identity (Yield 'f' (Yield 'o' (Yield 'o' Stop)))))+--+source :: Foldable f => f a -> SourceT m a+source = fromStepT . foldr Yield Stop++-- | Get the answers.+--+-- >>> runSourceT (source "foo" :: SourceT Identity Char)+-- ExceptT (Identity (Right "foo"))+--+-- >>> runSourceT (source "foo" :: SourceT [] Char)+-- ExceptT [Right "foo"]+--+runSourceT :: Monad m => SourceT m a -> ExceptT String m [a]+runSourceT (SourceT m) = ExceptT (m (runExceptT . runStepT))++runStepT :: Monad m => StepT m a -> ExceptT String m [a]+runStepT Stop = pure []+runStepT (Error err) = throwError err+runStepT (Skip s) = runStepT s+runStepT (Yield x s) = fmap (x :) (runStepT s)+runStepT (Effect ms) = lift ms >>= runStepT++{-+-- | >>> uncons (foldr Yield Stop "foo" :: StepT Identity Char)+-- Identity (Just ('f',Yield 'o' (Yield 'o' Stop)))+--+uncons :: Monad m => StepT m a -> m (Maybe (a, StepT m a))+uncons Stop = pure Nothing+uncons (Skip s) = uncons s+uncons (Yield x s) = pure (Just (x, s))+uncons (Effect ms) = ms >>= uncons+uncons (Error _) =+-}++-- | Filter values.+--+-- >>> toList $ mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..10]) :: [Int]+-- [1,3,5,7,9]+--+-- >>> mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..2]) :: SourceT Identity Int+-- fromStepT (Effect (Identity (Skip (Yield 1 (Skip Stop)))))+--+-- Illustrates why we need 'Skip'.+mapMaybe :: Functor m => (a -> Maybe b) -> SourceT m a -> SourceT m b+mapMaybe p (SourceT m) = SourceT $ \k -> m (k . mapMaybeStep p)++mapMaybeStep :: Functor m => (a -> Maybe b) -> StepT m a -> StepT m b+mapMaybeStep p = go where+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ go (Effect ms) = Effect (fmap go ms)+ go (Yield x s) = case p x of+ Nothing -> Skip (go s)+ Just y -> Yield y (go s)++-- | Run action for each value in the 'SourceT'.+--+-- >>> foreach fail print $ source ("abc" :: String)+-- 'a'+-- 'b'+-- 'c'+--+foreach+ :: Monad m+ => (String -> m ()) -- ^ error handler+ -> (a -> m ())+ -> SourceT m a+ -> m ()+foreach f g src = unSourceT src (foreachStep f g)++-- | See 'foreach'.+foreachStep+ :: Monad m+ => (String -> m ()) -- ^ error handler+ -> (a -> m ())+ -> StepT m a+ -> m ()+foreachStep f g = go where+ 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+-------------------------------------------------------------------------------++fromAction :: Functor m => (a -> Bool) -> m a -> SourceT m a+fromAction stop action = SourceT ($ fromActionStep stop action)+{-# INLINE fromAction #-}++fromActionStep :: Functor m => (a -> Bool) -> m a -> StepT m a+fromActionStep stop action = loop where+ loop = Effect $ fmap step action+ step x+ | stop x = Stop+ | otherwise = Yield x loop+{-# INLINE fromActionStep #-}++-------------------------------------------------------------------------------+-- File+-------------------------------------------------------------------------------++-- | Read file.+--+-- >>> foreach fail BS.putStr (readFile "servant.cabal")+-- cabal-version: 3.0+-- name: servant+-- ...+--+readFile :: FilePath -> SourceT IO BS.ByteString+readFile fp =+ SourceT $ \k ->+ withFile fp ReadMode $ \hdl ->+ k (readHandle hdl)+ where+ readHandle :: Handle -> StepT IO BS.ByteString+ readHandle hdl = fromActionStep BS.null (BS.hGet hdl 4096)++-------------------------------------------------------------------------------+-- Attoparsec+-------------------------------------------------------------------------------++-- | Transform using @attoparsec@ parser.+--+-- Note: @parser@ should not accept empty input!+--+-- >>> let parser = A.skipWhile A8.isSpace_w8 >> A.takeWhile1 A8.isDigit_w8+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ [fromString "1 2 3"])+-- Right ["1","2","3"]+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ map fromString ["1", "2", "3"])+-- Right ["123"]+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ map fromString ["1", "2 3", "4"])+-- Right ["12","34"]+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source [fromString "foobar"])+-- Left "Failed reading: takeWhile1"+--+transformWithAtto :: Monad m => A.Parser a -> SourceT m BS.ByteString -> SourceT m a+transformWithAtto parser = mapStepT (transformStepWithAtto parser)++transformStepWithAtto+ :: forall a m. Monad m+ => A.Parser a -> StepT m BS.ByteString -> StepT m a+transformStepWithAtto parser = go (A.parse parser) where+ p0 = A.parse parser++ go :: (BS.ByteString -> A.Result a)+ -> StepT m BS.ByteString -> StepT m a+ go _ (Error err) = Error err+ go p (Skip s) = Skip (go p s)+ go p (Effect ms) = Effect (fmap (go p) ms)+ go p Stop = case p mempty of+ A.Fail _ _ err -> Error err+ A.Done _ a -> Yield a Stop+ A.Partial _ -> Stop+ go p (Yield bs0 s) = loop p bs0 where+ loop p' bs+ | BS.null bs = Skip (go p' s)+ | otherwise = case p' bs of+ A.Fail _ _ err -> Error err+ A.Done bs' a -> Yield a (loop p0 bs')+ A.Partial p'' -> Skip (go p'' s)
− src/Servant/Utils/Enter.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} (- module Servant.Utils.Enter,- -- * natural-transformation re-exports- (:~>)(..),- ) where--import Control.Natural-import Control.Monad.Identity-import Control.Monad.Morph-import Control.Monad.Reader-import qualified Control.Monad.State.Lazy as LState-import qualified Control.Monad.State.Strict as SState-import qualified Control.Monad.Writer.Lazy as LWriter-import qualified Control.Monad.Writer.Strict as SWriter-import Data.Tagged (Tagged, retag)-import Prelude ()-import Prelude.Compat-import Servant.API---- | Helper type family to state the 'Enter' symmetry.-type family Entered m n api where- Entered m n (a -> api) = a -> Entered m n api- Entered m n (m a) = n a- Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2- Entered m n (Tagged m a) = Tagged n a--class- ( Entered m n typ ~ ret- , Entered n m ret ~ typ- ) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m- where- -- | Map the leafs of an API type.- enter :: (m :~> n) -> typ -> ret---- ** Servant combinators--instance- ( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2- , m1 ~ m2, n1 ~ n2- , Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2)- , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2)- ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2)- where- enter e (a :<|> b) = enter e a :<|> enter e b--instance- ( Enter typ m n ret- , Entered m n (a -> typ) ~ (a -> ret)- , Entered n m (a -> ret) ~ (a -> typ)- ) => Enter (a -> typ) m n (a -> ret)- where- enter arg f a = enter arg (f a)---- ** Leaf instances--instance- ( Entered m n (Tagged m a) ~ Tagged n a- , Entered n m (Tagged n a) ~ Tagged m a- ) => Enter (Tagged m a) m n (Tagged n a)- where- enter _ = retag--instance- ( Entered m n (m a) ~ n a- , Entered n m (n a) ~ m a- ) => Enter (m a) m n (n a)- where- enter (NT f) = f---- | Like `lift`.-liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m-liftNat = NT Control.Monad.Morph.lift--runReaderTNat :: r -> (ReaderT r m :~> m)-runReaderTNat a = NT (`runReaderT` a)--evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)-evalStateTLNat a = NT (`LState.evalStateT` a)--evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)-evalStateTSNat a = NT (`SState.evalStateT` a)---- | Log the contents of `SWriter.WriterT` with the function provided as the--- first argument, and return the value of the @WriterT@ computation-logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)-logWriterTSNat logger = NT $ \x -> do- (a, w) <- SWriter.runWriterT x- liftIO $ logger w- return a---- | Like `logWriterTSNat`, but for lazy @WriterT@.-logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)-logWriterTLNat logger = NT $ \x -> do- (a, w) <- LWriter.runWriterT x- liftIO $ logger w- return a---- | Like @mmorph@'s `hoist`.-hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)-hoistNat (NT n) = NT $ hoist n---- | Like @mmorph@'s `embed`.-embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)-embedNat (NT n) = NT $ embed n---- | Like @mmorph@'s `squash`.-squashNat :: (Monad m, MMonad t) => t (t m) :~> t m-squashNat = NT squash---- | Like @mmorph@'s `generalize`.-generalizeNat :: Applicative m => Identity :~> m-generalizeNat = NT (pure . runIdentity)
− src/Servant/Utils/Links.hs
@@ -1,367 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_HADDOCK not-home #-}---- | Type safe generation of internal links.------ Given an API with a few endpoints:------ >>> :set -XDataKinds -XTypeFamilies -XTypeOperators--- >>> import Servant.API--- >>> import Servant.Utils.Links--- >>> import Data.Proxy--- >>>--- >>>--- >>>--- >>> type Hello = "hello" :> Get '[JSON] Int--- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent--- >>> type API = Hello :<|> Bye--- >>> let api = Proxy :: Proxy API------ It is possible to generate links that are guaranteed to be within 'API' with--- 'safeLink'. The first argument to 'safeLink' is a type representing the API--- you would like to restrict links to. The second argument is the destination--- endpoint you would like the link to point to, this will need to end with a--- verb like GET or POST. Further arguments may be required depending on the--- type of the endpoint. If everything lines up you will get a 'Link' out the--- other end.------ You may omit 'QueryParam's and the like should you not want to provide them,--- but types which form part of the URL path like 'Capture' must be included.--- The reason you may want to omit 'QueryParam's is that safeLink is a bit--- magical: if parameters are included that could take input it will return a--- function that accepts that input and generates a link. This is best shown--- with an example. Here, a link is generated with no parameters:------ >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)--- >>> toUrlPiece (safeLink api hello :: Link)--- "hello"------ If the API has an endpoint with parameters then we can generate links with--- or without those:------ >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)--- >>> toUrlPiece $ safeLink api with (Just "Hubert")--- "bye?name=Hubert"------ >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)--- >>> toUrlPiece $ safeLink api without--- "bye"------ If you would like create a helper for generating links only within that API,--- you can partially apply safeLink if you specify a correct type signature--- like so:------ >>> :set -XConstraintKinds--- >>> :{--- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)--- >>> => Proxy endpoint -> MkLink endpoint--- >>> apiLink = safeLink api--- >>> :}------ Attempting to construct a link to an endpoint that does not exist in api--- will result in a type error like this:------ >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)--- >>> safeLink api bad_link--- ...--- ...Could not deduce...--- ...------ This error is essentially saying that the type family couldn't find--- bad_link under api after trying the open (but empty) type family--- `IsElem'` as a last resort.-module Servant.Utils.Links (- module Servant.API.TypeLevel,-- -- * Building and using safe links- --- -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.- safeLink- , allLinks- , URI(..)- -- * Adding custom types- , HasLink(..)- , Link- , linkURI- , linkURI'- , LinkArrayElementStyle (..)- -- ** Link accessors- , Param (..)- , linkSegments- , linkQueryParams-) where--import Data.List-import Data.Monoid.Compat ( (<>) )-import Data.Proxy ( Proxy(..) )-import qualified Data.Text as Text-import qualified Data.Text.Encoding as TE-import GHC.TypeLits ( KnownSymbol, symbolVal )-import Network.URI ( URI(..), escapeURIString, isUnreserved )-import Prelude ()-import Prelude.Compat--import Web.HttpApiData-import Servant.API.Alternative ( (:<|>)((:<|>)) )-import Servant.API.BasicAuth ( BasicAuth )-import Servant.API.Capture ( Capture, CaptureAll )-import Servant.API.ReqBody ( ReqBody )-import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )-import Servant.API.Header ( Header )-import Servant.API.RemoteHost ( RemoteHost )-import Servant.API.Verbs ( Verb )-import Servant.API.Sub ( type (:>) )-import Servant.API.Raw ( Raw )-import Servant.API.TypeLevel-import Servant.API.Experimental.Auth ( AuthProtect )---- | 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.-data Link = Link- { _segments :: [Escaped]- , _queryParams :: [Param]- } deriving Show--newtype Escaped = Escaped String--escaped :: String -> Escaped-escaped = Escaped . escapeURIString isUnreserved--getEscaped :: Escaped -> String-getEscaped (Escaped s) = s--instance Show Escaped where- showsPrec d (Escaped s) = showsPrec d s- show (Escaped s) = show s--linkSegments :: Link -> [String]-linkSegments = map getEscaped . _segments--linkQueryParams :: Link -> [Param]-linkQueryParams = _queryParams--instance ToHttpApiData Link where- toHeader = TE.encodeUtf8 . toUrlPiece- toUrlPiece l =- let uri = linkURI l- in Text.pack $ uriPath uri ++ uriQuery uri---- | Query parameter.-data Param- = SingleParam String Text.Text- | ArrayElemParam String Text.Text- | FlagParam String- deriving Show--addSegment :: Escaped -> Link -> Link-addSegment seg l = l { _segments = _segments l <> [seg] }--addQueryParam :: Param -> Link -> Link-addQueryParam qp l =- l { _queryParams = _queryParams l <> [qp] }---- | Transform 'Link' into 'URI'.------ >>> type API = "something" :> Get '[JSON] Int--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)--- something------ >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]--- sum?x[]=1&x[]=2&x[]=3------ >>> type API = "foo/bar" :> Get '[JSON] Int--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)--- foo%2Fbar------ >>> 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 = []}------ >>> linkURI $ safeLink someRoute someRoute "test@example.com"--- abc/test%40example.com----linkURI :: Link -> URI-linkURI = linkURI' LinkArrayElementBracket---- | How to encode array query elements.-data LinkArrayElementStyle- = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@- | LinkArrayElementPlain -- ^ @foo=1&foo=2@- deriving (Eq, Ord, Show, Enum, Bounded)---- | Configurable 'linkURI'.------ >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int--- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]--- sum?x[]=1&x[]=2&x[]=3------ >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]--- sum?x=1&x=2&x=3----linkURI' :: LinkArrayElementStyle -> Link -> URI-linkURI' addBrackets (Link segments q_params) =- URI mempty -- No scheme (relative)- Nothing -- Or authority (relative)- (intercalate "/" $ map getEscaped segments)- (makeQueries q_params) mempty- where- makeQueries :: [Param] -> String- makeQueries [] = ""- makeQueries xs =- "?" <> 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-- style = case addBrackets of- LinkArrayElementBracket -> "[]="- LinkArrayElementPlain -> "="--escape :: String -> String-escape = escapeURIString isUnreserved---- | Create a valid (by construction) relative URI with query params.------ This function will only typecheck if `endpoint` is part of the API `api`-safeLink- :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)- => 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-safeLink _ endpoint = toLink endpoint (Link mempty mempty)---- | Create all links in an API.------ Note that the @api@ type must be restricted to the endpoints that have--- valid links to them.------ >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double--- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)--- >>> :t fooLink--- fooLink :: Text -> Link--- >>> :t barLink--- barLink :: Int -> Link------ 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))--- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) :: *--- = Char -> (Int -> Link) :<|> (Double -> Link)----allLinks- :: forall api. HasLink api- => Proxy api- -> MkLink api-allLinks api = toLink api (Link mempty mempty)---- | Construct a toLink for an endpoint.-class HasLink endpoint where- type MkLink endpoint- toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to- -> Link- -> MkLink endpoint---- Naked symbol instance-instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where- type MkLink (sym :> sub) = MkLink sub- toLink _ =- toLink (Proxy :: Proxy sub) . addSegment (escaped seg)- where- seg = symbolVal (Proxy :: Proxy sym)----- QueryParam instances-instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)- => HasLink (QueryParam sym v :> sub) where- type MkLink (QueryParam sym v :> sub) = Maybe v -> MkLink sub- toLink _ l mv =- toLink (Proxy :: Proxy sub) $- maybe id (addQueryParam . SingleParam k . toQueryParam) mv l- where- k :: String- k = symbolVal (Proxy :: Proxy sym)--instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)- => HasLink (QueryParams sym v :> sub) where- type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub- toLink _ l =- toLink (Proxy :: Proxy sub) .- foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l- where- k = symbolVal (Proxy :: Proxy sym)--instance (KnownSymbol sym, HasLink sub)- => HasLink (QueryFlag sym :> sub) where- type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub- toLink _ l False =- toLink (Proxy :: Proxy sub) l- toLink _ l True =- toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l- where- k = symbolVal (Proxy :: Proxy sym)---- :<|> instance - Generate all links at once-instance (HasLink a, HasLink b) => HasLink (a :<|> b) where- type MkLink (a :<|> b) = MkLink a :<|> MkLink b- toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l---- Misc instances-instance HasLink sub => HasLink (ReqBody ct a :> sub) where- type MkLink (ReqBody ct a :> sub) = MkLink sub- toLink _ = toLink (Proxy :: Proxy sub)--instance (ToHttpApiData v, HasLink sub)- => HasLink (Capture sym v :> sub) where- type MkLink (Capture sym v :> sub) = v -> MkLink sub- toLink _ l v =- toLink (Proxy :: Proxy sub) $- addSegment (escaped . Text.unpack $ toUrlPiece v) l--instance (ToHttpApiData v, HasLink sub)- => HasLink (CaptureAll sym v :> sub) where- type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub- toLink _ l vs =- toLink (Proxy :: Proxy sub) $- foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs--instance HasLink sub => HasLink (Header sym a :> sub) where- type MkLink (Header sym a :> sub) = MkLink sub- toLink _ = toLink (Proxy :: Proxy sub)--instance HasLink sub => HasLink (RemoteHost :> sub) where- type MkLink (RemoteHost :> sub) = MkLink sub- toLink _ = toLink (Proxy :: Proxy sub)--instance HasLink sub => HasLink (BasicAuth realm a :> sub) where- type MkLink (BasicAuth realm a :> sub) = MkLink sub- toLink _ = toLink (Proxy :: Proxy sub)---- Verb (terminal) instances-instance HasLink (Verb m s ct a) where- type MkLink (Verb m s ct a) = Link- toLink _ = id--instance HasLink Raw where- type MkLink Raw = Link- toLink _ = id---- AuthProtext instances-instance HasLink sub => HasLink (AuthProtect tag :> sub) where- type MkLink (AuthProtect tag :> sub) = MkLink sub- toLink _ = toLink (Proxy :: Proxy sub)---- $setup--- >>> import Servant.API--- >>> import Data.Text (Text)
test/Servant/API/ContentTypesSpec.hs view
@@ -8,29 +8,34 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where -import Prelude ()-import Prelude.Compat--import Data.Aeson.Compat-import Data.ByteString.Char8 (ByteString, append, pack)-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSL8+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)-import qualified Data.List.NonEmpty as NE-import Data.Maybe (fromJust, isJust, isNothing)+import Data.Function+ (on)+import Data.List+ (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 Data.String+ (IsString (..))+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 Text.Read (readMaybe)-import "quickcheck-instances" Test.QuickCheck.Instances ()+import "quickcheck-instances" Test.QuickCheck.Instances ()+import Text.Read+ (readMaybe) import Servant.API.ContentTypes @@ -70,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 @@ -127,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 @@ -188,17 +213,13 @@ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" "foobar" `shouldBe` (Nothing :: Maybe (Either String Int)) -#if MIN_VERSION_aeson(0,9,0)- -- 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)-#endif-+ property $ \x -> mimeUnrender (Proxy :: Proxy JSON) x+ `shouldBe` (eitherDecode x :: Either String String) data SomeData = SomeData { record1 :: String, record2 :: Int } deriving (Generic, Eq, Show)@@ -217,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 ]@@ -238,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@@ -250,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
@@ -1,11 +1,19 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Servant.API.ResponseHeadersSpec where -import Test.Hspec+import Data.Proxy+import GHC.TypeLits+import Test.Hspec -import Servant.API.Header-import Servant.API.ResponseHeaders+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
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+module Servant.API.StreamSpec where++import Control.Monad.Except+ (runExcept)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Functor.Identity+ (Identity (..))+import Data.Proxy+ (Proxy (..))+import Data.String+ (fromString)+import Servant.API.Stream+import Servant.Types.SourceT+import Test.Hspec+import Test.QuickCheck+ (Property, property, (===))+import Test.QuickCheck.Instances ()++spec :: Spec+spec = describe "Servant.API.Stream" $ do+ describe "NoFraming" $ do+ let framingUnrender' = framingUnrender (Proxy :: Proxy NoFraming) (Right . LBS.toStrict)+ framingRender' = framingRender (Proxy :: Proxy NoFraming) LBS.fromStrict++ it "framingUnrender" $+ property $ \bss ->+ runUnrenderFrames framingUnrender' bss === map Right (bss :: [BS.ByteString])++ it "roundtrip" $+ property $ roundtrip framingRender' framingUnrender'++ describe "NewlineFraming" $ do+ let tp = framingUnrender (Proxy :: Proxy NewlineFraming) (Right . LBS.toStrict)+ let re = framingRender (Proxy :: Proxy NewlineFraming) id++ it "framingRender examples" $ do+ runRenderFrames re [] `shouldBe` Right ""+ runRenderFrames re ["foo", "bar", "baz"] `shouldBe` Right "foo\nbar\nbaz\n"++ it "framingUnrender examples" $ do+ let expected n = map Right [fromString ("foo" ++ show (n :: Int)), "bar", "baz"]++ runUnrenderFrames tp ["foo1\nbar\nbaz"] `shouldBe` expected 1+ runUnrenderFrames tp ["foo2\n", "bar\n", "baz"] `shouldBe` expected 2+ runUnrenderFrames tp ["foo3\nb", "ar\nbaz"] `shouldBe` expected 3++ it "roundtrip" $ do+ let framingUnrender' = framingUnrender (Proxy :: Proxy NewlineFraming) Aeson.eitherDecode+ let framingRender' = framingRender (Proxy :: Proxy NewlineFraming) (Aeson.encode :: Int -> LBS.ByteString)++ property $ roundtrip framingRender' framingUnrender'++ -- it "fails if input doesn't contain newlines often" $+ -- runUnrenderFrames tp ["foo", "bar"] `shouldSatisfy` any isLeft++ describe "NetstringFraming" $ do+ let tp = framingUnrender (Proxy :: Proxy NetstringFraming) (Right . LBS.toStrict)+ let re = framingRender (Proxy :: Proxy NetstringFraming) id++ it "framingRender examples" $ do+ runRenderFrames re [] `shouldBe` Right ""+ runRenderFrames re ["foo", "bar", "baz"] `shouldBe` Right "3:foo,3:bar,3:baz,"++ it "framingUnrender examples" $ do+ let expected n = map Right [fromString ("foo" ++ show (n :: Int)), "bar", "baz"]++ runUnrenderFrames tp ["4:foo1,3:bar,3:baz,"] `shouldBe` expected 1+ runUnrenderFrames tp ["4:foo2,", "3:bar,", "3:baz,"] `shouldBe` expected 2+ runUnrenderFrames tp ["4:foo3,3:b", "ar,3:baz,"] `shouldBe` expected 3++ it "roundtrip" $ do+ let framingUnrender' = framingUnrender (Proxy :: Proxy NetstringFraming) Aeson.eitherDecode+ let framingRender' = framingRender (Proxy :: Proxy NetstringFraming) (Aeson.encode :: Int -> LBS.ByteString)++ property $ roundtrip framingRender' framingUnrender'++roundtrip+ :: (Eq a, Show a)+ => (SourceT Identity a -> SourceT Identity LBS.ByteString)+ -> (SourceT Identity BS.ByteString -> SourceT Identity a)+ -> [a]+ -> Property+roundtrip render unrender xs =+ map Right xs === runUnrenderFrames (unrender . fmap LBS.toStrict . render) xs++runRenderFrames :: (SourceT Identity a -> SourceT Identity LBS.ByteString) -> [a] -> Either String LBS.ByteString+runRenderFrames f = fmap mconcat . runExcept . runSourceT . f . source++runUnrenderFrames :: (SourceT Identity b -> SourceT Identity a) -> [b] -> [Either String a]+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]+ go (Skip s) = go s+ go (Yield x s) = Right x : go s+ go (Effect ms) = go (runIdentity ms)
+ test/Servant/LinksSpec.hs view
@@ -0,0 +1,250 @@+{-# 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)++type TestApi =+ -- Capture and query params+ "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent+ :<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent+ :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent++ -- 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+ :<|> "post" :> ReqBody '[JSON] Bool :> Post '[JSON] NoContent+ :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent+ :<|> "raw" :> Raw+ :<|> NoEndpoint++type LinkableApi =+ "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+ let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)+ apiLink l1 "hi" `shouldBeLink` "hello/hi"++ let l2 = Proxy :: Proxy ("hello" :> Capture "name" String+ :> QueryParam "capital" Bool+ :> Delete '[JSON] NoContent)+ apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"++ let l4 = Proxy :: Proxy ("hi" :> Capture "name" String+ :> QueryParam' '[Required] "capital" Bool+ :> Delete '[JSON] NoContent)+ apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false"++ it "generates correct links for CaptureAll" $ do+ apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))+ ["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"+ apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post"+ apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"+ apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw"++ it "can generate all links for an API that has only linkable endpoints" $ do+ let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)+ simple `shouldBeLink` "get"+ allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius"++ 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,+-- we'll just use doctest+--+-- with TypeError comparing for errors is difficult.+--+-- >>> apiLink (Proxy :: Proxy WrongPath)+-- ...+-- ......:...:...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongReturnType)+-- ...+-- ...Could not deduce...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongContentType)+-- ...+-- ......:...:...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongMethod)+-- ...+-- ...Could not deduce...+-- ...+--+-- >>> apiLink (Proxy :: Proxy NotALink)+-- ...+-- ...Could not deduce...+-- ...+--+-- >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint)+-- ...+-- <interactive>...+-- ...+--+-- sanity check+-- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood)+-- "get"+type WrongPath = "getTypo" :> Get '[JSON] NoContent+type WrongReturnType = "get" :> Get '[JSON] Bool+type WrongContentType = "get" :> Get '[OctetStream] NoContent+type WrongMethod = "get" :> Post '[JSON] NoContent+type NotALink = "hello" :> ReqBody '[JSON] Bool :> Get '[JSON] Bool+type AllGood = "get" :> Get '[JSON] NoContent+type NoEndpoint = "empty" :> EmptyAPI
− test/Servant/Utils/EnterSpec.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}-module Servant.Utils.EnterSpec where--import Test.Hspec (Spec)--import Servant.API-import Servant.Utils.Enter------------------------------------------------------------------------------------ https://github.com/haskell-servant/servant/issues/734------------------------------------------------------------------------------------ This didn't fail if executed in GHCi; cannot have as a doctest.--data App a--f :: App :~> App-f = NT id--server :: App Int :<|> (String -> App Bool)-server = undefined--server' :: App Int :<|> (String -> App Bool)-server' = enter f server------------------------------------------------------------------------------------ Spec----------------------------------------------------------------------------------spec :: Spec-spec = return ()
− test/Servant/Utils/LinksSpec.hs
@@ -1,129 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Servant.Utils.LinksSpec where--import Data.Proxy (Proxy (..))-import Test.Hspec (Expectation, Spec, describe, it,- shouldBe)-import Data.String (fromString)--import Servant.API-import Servant.Utils.Links (allLinks)--type TestApi =- -- Capture and query params- "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent- :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent-- -- Flags- :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent-- -- All of the verbs- :<|> "get" :> Get '[JSON] NoContent- :<|> "put" :> Put '[JSON] NoContent- :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] NoContent- :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent- :<|> "raw" :> Raw- :<|> NoEndpoint--type LinkableApi =- "all" :> CaptureAll "names" String :> Get '[JSON] NoContent- :<|> "get" :> Get '[JSON] NoContent---apiLink :: (IsElem endpoint TestApi, HasLink endpoint)- => Proxy endpoint -> MkLink endpoint-apiLink = safeLink (Proxy :: Proxy TestApi)---- | 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--spec :: Spec-spec = describe "Servant.Utils.Links" $ do- it "generates correct links for capture query params" $ do- let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)- apiLink l1 "hi" `shouldBeLink` "hello/hi"-- let l2 = Proxy :: Proxy ("hello" :> Capture "name" String- :> QueryParam "capital" Bool- :> Delete '[JSON] NoContent)- apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"-- it "generates correct links for CaptureAll" $ do- apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))- ["roads", "lead", "to", "rome"]- `shouldBeLink` "all/roads/lead/to/rome"-- 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 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"- apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post"- apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"- apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw"-- it "can generate all links for an API that has only linkable endpoints" $ do- let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi)- simple- `shouldBeLink` "get"- allNames ["Seneca", "Aurelius"]- `shouldBeLink` "all/Seneca/Aurelius"----- |--- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,--- we'll just use doctest------ with TypeError comparing for errors is difficult.------ >>> apiLink (Proxy :: Proxy WrongPath)--- ...--- ......:...:...--- ...------ >>> apiLink (Proxy :: Proxy WrongReturnType)--- ...--- ...Could not deduce...--- ...------ >>> apiLink (Proxy :: Proxy WrongContentType)--- ...--- ......:...:...--- ...------ >>> apiLink (Proxy :: Proxy WrongMethod)--- ...--- ...Could not deduce...--- ...------ >>> apiLink (Proxy :: Proxy NotALink)--- ...--- ...Could not deduce...--- ...------ >>> apiLink (Proxy :: Proxy NoEndpoint)--- ...--- ...No instance for...--- ...------ sanity check--- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood)--- "get"-type WrongPath = "getTypo" :> Get '[JSON] NoContent-type WrongReturnType = "get" :> Get '[JSON] Bool-type WrongContentType = "get" :> Get '[OctetStream] NoContent-type WrongMethod = "get" :> Post '[JSON] NoContent-type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool-type AllGood = "get" :> Get '[JSON] NoContent-type NoEndpoint = "empty" :> EmptyAPI
− test/doctests.hs
@@ -1,25 +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, pkgs, module_sources)-import Data.Foldable (traverse_)-import Test.DocTest--main :: IO ()-main = do- traverse_ putStrLn args- doctest args- where- args = flags ++ pkgs ++ module_sources