servant 0.1 → 0.20.3.0
raw patch · 54 files changed
Files
- CHANGELOG.md +1068/−0
- LICENSE +2/−2
- Setup.hs +1/−1
- servant.cabal +191/−31
- src/Servant/API.hs +173/−0
- src/Servant/API/Alternative.hs +57/−0
- src/Servant/API/BasicAuth.hs +35/−0
- src/Servant/API/Capture.hs +42/−0
- src/Servant/API/ContentTypes.hs +423/−0
- src/Servant/API/Description.hs +84/−0
- src/Servant/API/Empty.hs +10/−0
- src/Servant/API/Experimental/Auth.hs +14/−0
- src/Servant/API/Fragment.hs +27/−0
- src/Servant/API/Generic.hs +149/−0
- src/Servant/API/Header.hs +34/−0
- src/Servant/API/Host.hs +13/−0
- src/Servant/API/HttpVersion.hs +20/−0
- src/Servant/API/IsSecure.hs +41/−0
- 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 +59/−0
- src/Servant/API/QueryString.hs +86/−0
- src/Servant/API/Range.hs +68/−0
- src/Servant/API/Raw.hs +20/−0
- src/Servant/API/RemoteHost.hs +26/−0
- src/Servant/API/ReqBody.hs +34/−0
- src/Servant/API/ResponseHeaders.hs +266/−0
- 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 +29/−0
- src/Servant/API/TypeErrors.hs +59/−0
- src/Servant/API/TypeLevel.hs +317/−0
- 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 +21/−0
- src/Servant/API/Verbs.hs +195/−0
- src/Servant/API/WithNamedContext.hs +23/−0
- src/Servant/API/WithResource.hs +3/−0
- src/Servant/Context.hs +0/−47
- src/Servant/Error.hs +0/−94
- src/Servant/Links.hs +711/−0
- src/Servant/Prelude.hs +0/−163
- src/Servant/Resource.hs +0/−193
- src/Servant/Test/ComprehensiveAPI.hs +81/−0
- src/Servant/Types/Internal/Response.hs +17/−0
- src/Servant/Types/SourceT.hs +399/−0
- test/Servant/API/ContentTypesSpec.hs +276/−0
- test/Servant/API/ResponseHeadersSpec.hs +49/−0
- test/Servant/API/StreamSpec.hs +99/−0
- test/Servant/LinksSpec.hs +250/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,1068 @@+[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+------++### Bug fixes++- Prevent double-escaping in link segments+ ([#835](https://github.com/haskell-servant/servant/issues/835)+ [#878](https://github.com/haskell-servant/servant/pull/878))++0.12+---++### Significant changes++- *servant-client* *servant-client-core*+ Factored out of `servant-client` all the functionality that was+ independent of the `http-client` backend.+ ([#803](https://github.com/haskell-servant/servant/pull/803)+ [#821](https://github.com/haskell-servant/servant/issues/821))++ If you have own combinators, you'll need to add an additional `m` argument+ in `HasClient`, `Client` and `clientWithRoute`:++ ```diff+ -class HasClient api+ - type Client (api :: *) :: *+ - clientWithRoute :: Proxy api -> Req -> Client api+ +class HasClient m api+ + type Client (m :: * -> *) (api :: *) :: *+ + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api+ ```++ See https://github.com/haskell-servant/servant-auth/pull/67/commits/f777818e3cc0fa3ed2346baff8328e96d62b1790 for a real world example.++- *servant-server* Added `hoistServer` member to the `HasServer` class, which is `HasServer`+ specific `enter`.+ ([#804](https://github.com/haskell-servant/servant/pull/804)+ [#824](https://github.com/haskell-servant/servant/pull/824))++ `enter` isn't exported from `Servant` module anymore. You can change+ `enter` to `hoistServer` in a straight forward way.+ Unwrap natural transformation and add an api type `Proxy`:++ ```diff+ -server = enter (NT nt) impl+ +server = hoistServer (Proxy :: Proxy MyApi) nt impl+ ```++ If you have own combinators, you'll need to define a new method of+ `HasServer` class, for example:++ ```haskell+ type ServerT (MyCombinator :> api) m = MyValue -> ServerT api m+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s+ ```++ See https://github.com/haskell-servant/servant-auth/pull/67/commits/8ee3b6315247ac076516213fd7cfcdbfdb583ac9 for a real world example.++- Add `Description` and `Summary` combinators+ ([#767](https://github.com/haskell-servant/servant/pull/767))++ It's possible to annotate endpoints with free form text.+ This information is used by e.g. by `servant-swagger`, see screenshot in+ https://github.com/phadej/servant-swagger-ui++- Lower `:>` and `:<|>` infix precedence to 4 and 3 respectively+ ([#761](https://github.com/haskell-servant/servant/issues/761))++ This shouldn't affect you, except if you define your own infix operators+ for Servant type-level DSL.++### Other changes++- *servant-foreign* Derive `Data` for all types+ ([#809](https://github.com/haskell-servant/servant/pull/809))+- *servant-docs* Add authentication lenses+ ([#787](https://github.com/haskell-servant/servant/pull/787))+- *servant-docs* Generated markdown improvements+ ([#813](https://github.com/haskell-servant/servant/pull/787)+ [#767](https://github.com/haskell-servant/servant/pull/767)+ [#790](https://github.com/haskell-servant/servant/pull/790)+ [#788](https://github.com/haskell-servant/servant/pull/788))+- Add `addLinks` to generate all links for unnested APIs.+ ([#851](https://github.com/haskell-servant/servant/pull/851))+- Allow newest dependencies+ ([#772](https://github.com/haskell-servant/servant/pull/772)+ [#842](https://github.com/haskell-servant/servant/pull/842))+- Documentation improvements and typo fixes+ ([#757](https://github.com/haskell-servant/servant/pull/757)+ [#771](https://github.com/haskell-servant/servant/pull/771)+ [#775](https://github.com/haskell-servant/servant/pull/775)+ [#790](https://github.com/haskell-servant/servant/pull/790)+ [#791](https://github.com/haskell-servant/servant/pull/791)+ [#806](https://github.com/haskell-servant/servant/pull/806))+- Development process improvements+ ([#764](https://github.com/haskell-servant/servant/pull/764)+ [#839](https://github.com/haskell-servant/servant/pull/839))++0.11+----++### Breaking changes++- `Enter` refactored+ ([#734](https://github.com/haskell-servant/servant/issues/734)+ , [#736](https://github.com/haskell-servant/servant/pull/736))++### Other changes++- Add a type representing an empty API+ ([#753](https://github.com/haskell-servant/servant/pull/753))+- Add `linkURI'` and `Link` accessors+ ([#745](https://github.com/haskell-servant/servant/pull/745)+ , [#717](https://github.com/haskell-servant/servant/pull/717)+ , [#715](https://github.com/haskell-servant/servant/issues/715))+- Prepare for GHC-8.2+ ([#722](https://github.com/haskell-servant/servant/pull/722))+- Add `HasLink AuthProtect` instance+ ([#720](https://github.com/haskell-servant/servant/pull/720))+- `AllCTRender [] ()` `TypeError` (use `NoContent`)+ ([#671](https://github.com/haskell-servant/servant/pull/671))+- Documentation improvements and typo fixes+ ([#702](https://github.com/haskell-servant/servant/pull/702)+ , [#709](https://github.com/haskell-servant/servant/pull/709)+ , [#716](https://github.com/haskell-servant/servant/pull/716)+ , [#725](https://github.com/haskell-servant/servant/pull/725)+ , [#727](https://github.com/haskell-servant/servant/pull/727))++0.10+----++### Breaking changes++* Use `NT` from `natural-transformation` for `Enter`+ ([#616](https://github.com/haskell-servant/servant/issues/616))++* Change to `MkLink (Verb ...) = Link` (previously `URI`). To consume `Link`+ use its `ToHttpApiData` instance or `linkURI`.+ ([#527](https://github.com/haskell-servant/servant/issues/527))++### Other changes++* Add `Servant.API.TypeLevel` module with type families to work with API types.+ ([#345](https://github.com/haskell-servant/servant/pull/345)+ , [#305](https://github.com/haskell-servant/servant/issues/305))++* Default JSON content type change to `application/json;charset=utf-8`.+ ([#263](https://github.com/haskell-servant/servant/issues/263))+ Related browser bugs:+ [Chromium](https://bugs.chromium.org/p/chromium/issues/detail?id=438464) and+ [Firefox](https://bugzilla.mozilla.org/show_bug.cgi?id=918742)++* `Accept` class may accept multiple content-types. `MimeUnrender` adopted as well.+ ([#613](https://github.com/haskell-servant/servant/pull/614)+ , [#615](https://github.com/haskell-servant/servant/pull/615))++0.9.1+------++* Added 'noHeader' function for *not* adding response headers.++0.9+---++* Added Eq, Show, Read, Generic and Ord instances to IsSecure+* BACKWARDS INCOMPATIBLE: replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo`+* BACKWARDS INCOMPATIBLE: Moved `From/ToFormUrlEncoded` classes, which were renamed to `From/ToForm` to `http-api-data`++0.8.1+----++* Add `CaptureAll` combinator. Captures all of the remaining segments in a URL.+* Add `Servant.API.TypeLevel` module, with frequently used type-level+functionaliy.++0.8+---++* Minor fixes, documentation changes and cabal tweaks++0.7.1+-----++* Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478)+* Allow to set the same header multiple times in responses.++0.5+---++* Add `WithNamedConfig` combinator.+* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators+* Fix safeLink, so Header is not in fact required.+* Add more instances for (:<|>)+* Use `http-api-data` instead of `Servant.Common.Text`+* Remove matrix params.+* Add PlainText String MimeRender and MimeUnrender instances.+* Add new `Verbs` combinator, and make all existing and new verb combinators+type synonyms of it.+* Add `BasicAuth` combinator to support Basic authentication+* Add generalized authentication support++0.4.2+-----+* Fix missing cases for `Patch` in `safeLink`++0.4.1+-----+* Allow whitespace after parsing JSON+* Stricter matching for `safeLink` for `Capture`++0.4+---+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body+* Multiple content-type/accept support for all the relevant combinators+* Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box+* Type-safe link generation to API endpoints+* Support for the PATCH HTTP method+* Removed the home-made QuasiQuote for writing API types in a more human-friendly format until we come up with a better design for it+* Make most if not all of the haddock code examples run through doctest+* Some general code cleanup+* Add response headers
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Alp Mestanogullari+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Alp Mestanogullari nor the names of other+ * Neither the name of Zalora South East Asia Pte Ltd nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
servant.cabal view
@@ -1,37 +1,197 @@-name: servant-version: 0.1-synopsis: A library to generate REST-style webservices on top of scotty, handling all the boilerplate for you-description: - An abstraction for 'Resource's that can support any number- of operations, which will be tagged at the type-level.+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 .- This package however does provide standard /REST-y/ operations- ('Servant.Operation.Add', 'Servant.Operation.Delete', 'Servant.Operation.ListAll'- , 'Servant.Operation.Update' and 'Servant.Operation.View') and lets you define your- own.+ You can learn about the basics in the <http://docs.servant.dev/en/stable/tutorial/index.html tutorial>. .- You can then actually make a service out of a 'Servant.Resource.Resource' description- using any backend you like (we currently only provide a- <http://hackage.haskell.org/package/scotty scotty> backend in- the /servant-scotty/ package).-homepage: http://github.com/zalora/servant-license: BSD3-license-file: LICENSE-author: Alp Mestanogullari-maintainer: alp@zalora.com-copyright: 2014 Zalora SEA-category: Web, Database-build-type: Simple-cabal-version: >=1.10+ <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG> +homepage: http://docs.servant.dev/+bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD-3-Clause+license-file: LICENSE+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright:+ 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors++build-type: Simple+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+ location: http://github.com/haskell-servant/servant.git++common extensions+ default-extensions:+ AllowAmbiguousTypes+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ NoStarIsType+ OverloadedLabels+ OverloadedStrings+ PackageImports+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns++ default-language: Haskell2010++common ghc-options+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ -fhide-source-paths -Wno-unused-do-bind -fdicts-strict+ -Wno-unticked-promoted-constructors -Werror=unused-imports+ -Wunused-packages+ library+ import: extensions+ import: ghc-options exposed-modules:- Servant.Context- , Servant.Error- , Servant.Prelude- , Servant.Resource+ Servant.API+ Servant.API.Alternative+ Servant.API.BasicAuth+ Servant.API.Capture+ Servant.API.ContentTypes+ Servant.API.Description+ Servant.API.Empty+ Servant.API.Experimental.Auth+ Servant.API.Fragment+ Servant.API.Generic+ Servant.API.Header+ Servant.API.Host+ Servant.API.HttpVersion+ Servant.API.IsSecure+ Servant.API.Modifiers+ Servant.API.NamedRoutes+ Servant.API.QueryParam+ Servant.API.QueryString+ Servant.API.Range+ Servant.API.Raw+ Servant.API.RemoteHost+ Servant.API.ReqBody+ Servant.API.ResponseHeaders+ Servant.API.ServerSentEvents+ Servant.API.Status+ Servant.API.Stream+ Servant.API.Sub+ Servant.API.TypeErrors+ Servant.API.TypeLevel+ Servant.API.TypeLevel.List+ Servant.API.UVerb+ Servant.API.MultiVerb+ Servant.API.UVerb.Union+ Servant.API.Vault+ Servant.API.Verbs+ Servant.API.WithNamedContext+ Servant.API.WithResource++ -- Types+ exposed-modules:+ Servant.Types.SourceT+ Servant.Types.Internal.Response++ -- Test stuff+ exposed-modules: Servant.Test.ComprehensiveAPI++ -- 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 && <5- hs-source-dirs: src- default-language: Haskell2010- ghc-options: -Wall+ , base >= 4.16.4.0 && <4.22+ , bytestring >=0.11 && <0.13+ , constraints >=0.2+ , containers >=0.6.5.1 && <0.9+ , mtl ^>=2.2.2 || ^>=2.3.1+ , sop-core >=0.4.0.0 && <0.6+ , generics-sop ^>=0.5.1+ , text >=1.2.3.0 && <2.2+ , transformers >=0.5.2.0 && <0.7++ -- We depend (heavily) on the API of these packages:+ -- i.e. re-export, or allow using without direct dependency+ build-depends:+ , http-api-data >=0.4.1 && <0.7+ , singleton-bool >=0.1.4 && <0.2++ -- Other dependencies: Lower bound around what is in the latest Stackage LTS.+ -- Here can be exceptions if we really need features from the newer versions.+ build-depends:+ , 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+ import: extensions+ import: ghc-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Servant.API.ContentTypesSpec+ Servant.API.ResponseHeadersSpec+ Servant.API.StreamSpec+ Servant.LinksSpec++ -- Dependencies inherited from the library. No need to specify bounds.+ build-depends:+ , aeson+ , base+ , bytestring+ , http-media+ , mtl+ , network-uri+ , servant+ , text++ -- Additional dependencies+ build-depends:+ , hspec >=2.6.0 && <2.12+ , QuickCheck >=2.12.6.1 && <2.16+ , quickcheck-instances >=0.3.19 && <0.4++ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12
+ src/Servant/API.hs view
@@ -0,0 +1,173 @@+module Servant.API (++ -- * Combinators+ module Servant.API.Sub,+ -- | Type-level combinator for expressing subrouting: @':>'@+ module Servant.API.Alternative,+ -- | 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,+ -- | Retrieving the IP of the client+ module Servant.API.IsSecure,+ -- | Is the request made through HTTPS?+ module Servant.API.Vault,+ -- | 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,++ -- * Endpoints description+ module Servant.API.Description,++ -- * Content Types+ module Servant.API.ContentTypes,+ -- | Serializing and deserializing types based on @Accept@ and+ -- @Content-Type@ headers.++ -- * Response Headers+ module Servant.API.ResponseHeaders,++ -- * Untyped endpoints+ module Servant.API.Raw,+ -- | Plugging in a wai 'Network.Wai.Application', serving directories++ -- * FromHttpApiData and ToHttpApiData+ module Web.HttpApiData,+ -- | Classes and instances for types that can be converted to and from HTTP API data.+++ -- * Experimental modules+ module Servant.API.Experimental.Auth,+ -- | General Authentication++ -- * Links+ module Servant.Links,+ -- | Type-safe internal URIs++ -- * Re-exports+ If,+ SBool (..), SBoolI (..)+ ) where++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
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Alternative ((:<|>)(..)) where++#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.+--+-- Example:+--+-- >>> :{+--type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+-- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books+-- :}+data a :<|> b = a :<|> b+ deriving stock (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded)+infixr 3 :<|>++instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where+ (a :<|> b) <> (a' :<|> b') = (a <> a') :<|> (b <> b')++instance (Monoid a, Monoid b) => Monoid (a :<|> b) where+ mempty = mempty :<|> mempty++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+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> instance ToJSON Book where { toJSON = undefined }
+ src/Servant/API/BasicAuth.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-# LANGUAGE PolyKinds #-}++module Servant.API.BasicAuth where++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>.+--+-- *IMPORTANT*: Only use Basic Auth over HTTPS! Credentials are not hashed or+-- encrypted. Note also that because the same credentials are sent on every+-- request, Basic Auth is not as secure as some alternatives. Further, the+-- implementation in servant-server does not protect against some types of+-- timing attacks.+--+-- 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 :: Type)+ deriving (Typeable)++-- | A simple datatype to hold data required to decorate a request+data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString+ , basicAuthPassword :: !ByteString+ }
+ src/Servant/API/Capture.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Capture (Capture, Capture', CaptureAll) where++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+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@.+--+-- Example:+--+-- >>> -- GET /src/*+-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile+data CaptureAll (sym :: Symbol) (a :: Type)+ deriving (Typeable)++-- $setup+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> instance ToJSON Book where { toJSON = undefined }+-- >>> data SourceFile+-- >>> instance ToJSON SourceFile where { toJSON = undefined }
+ src/Servant/API/ContentTypes.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | 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+-- a particular Content-Type.+--+-- Content-Types are used in `ReqBody` and the method combinators:+--+-- >>> 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+-- formats (depending on the @Accept@ header).+--+-- If you would like to support Content-Types beyond those provided here,+-- then:+--+-- (1) Declare a new data type with no constructors (e.g. @data HTML@).+-- (2) Make an instance of it for `Accept`.+-- (3) If you want to be able to serialize data *into* that+-- Content-Type, make an instance of it for `MimeRender`.+-- (4) If you want to be able to deserialize data *from* that+-- Content-Type, make an instance of it for `MimeUnrender`.+--+-- Note that roles are reversed in @servant-server@ and @servant-client@:+-- to be able to serve (or even typecheck) a @Get '[JSON, XML] MyData@,+-- you'll need to have the appropriate `MimeRender` instances in scope,+-- whereas to query that endpoint with @servant-client@, you'll need+-- a `MimeUnrender` instance in scope.+module Servant.API.ContentTypes+ (+ -- * Provided Content-Types+ JSON+ , PlainText+ , FormUrlEncoded+ , OctetStream+ , EventStream++ -- * Building your own Content-Type+ , Accept(..)+ , MimeRender(..)+ , MimeUnrender(..)++ -- * NoContent+ , NoContent(..)++ -- * Internal+ , AcceptHeader(..)+ , AllCTRender(..)+ , AllCTUnrender(..)+ , AllMime(..)+ , AllMimeRender(..)+ , AllMimeUnrender(..)+ , eitherDecodeLenient+ , canHandleAcceptH+ , EventStreamChunk(..)+ ) where++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 Data.Kind+ (Type)+import qualified Data.List.NonEmpty as NE+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 GHC.TypeLits as TL+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++-- | Instances of 'Accept' represent mimetypes. They are used for matching+-- against the @Accept@ HTTP header of the request, and for setting the+-- @Content-Type@ header of the response+--+-- Example:+--+-- >>> import Network.HTTP.Media ((//), (/:))+-- >>> data HTML+-- >>> :{+--instance Accept HTML where+-- contentType _ = "text" // "html" /: ("charset", "utf-8")+-- :}+--+class Accept ctype where+ contentType :: Proxy ctype -> M.MediaType+ contentType = NE.head . contentTypes++ contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType+ contentTypes = (NE.:| []) . contentType++ {-# MINIMAL contentType | contentTypes #-}++-- | @application/json@+instance Accept JSON where+ contentTypes _ =+ "application" M.// "json" M./: ("charset", "utf-8") NE.:|+ [ "application" M.// "json" ]++-- | @application/x-www-form-urlencoded@+instance Accept FormUrlEncoded where+ contentType _ = "application" M.// "x-www-form-urlencoded"++-- | @text/plain;charset=utf-8@+instance Accept PlainText where+ contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")++-- | @application/octet-stream@+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)++-- * Render (serializing)++-- | Instantiate this class to register a way of serializing a type based+-- on the @Accept@ header.+--+-- Example:+--+-- > data MyContentType+-- >+-- > instance Accept MyContentType where+-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")+-- >+-- > instance Show a => MimeRender MyContentType a where+-- > mimeRender _ val = pack ("This is MINE! " ++ show val)+-- >+-- > type MyAPI = "path" :> Get '[MyContentType] Int+--+class Accept ctype => MimeRender ctype a where+ mimeRender :: Proxy ctype -> a -> ByteString++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 #-}+ (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++instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.")+ => AllCTRender '[] () where+ handleAcceptH _ _ _ = error "unreachable"++--------------------------------------------------------------------------+-- * Unrender++-- | Instantiate this class to register a way of deserializing a type based+-- on the request's @Content-Type@ header.+--+-- >>> import Network.HTTP.Media hiding (Accept)+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSC+-- >>> data MyContentType = MyContentType String+--+-- >>> :{+--instance Accept MyContentType where+-- contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")+-- :}+--+-- >>> :{+--instance Read a => MimeUnrender MyContentType a where+-- mimeUnrender _ bs = case BSC.take 12 bs of+-- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs+-- _ -> Left "didn't start with the magic incantation"+-- :}+--+-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int+--+class Accept ctype => MimeUnrender ctype a where+ mimeUnrender :: Proxy ctype -> ByteString -> Either String a+ mimeUnrender p = mimeUnrenderWithType p (contentType p)++ -- | Variant which is given the actual 'M.MediaType' provided by the other party.+ --+ -- In the most cases you don't want to branch based on the 'M.MediaType'.+ -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.+ mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a+ mimeUnrenderWithType p _ = mimeUnrender p++ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}++class AllCTUnrender (list :: [Type]) a where+ canHandleCTypeH+ :: Proxy list+ -> ByteString -- Content-Type header+ -> Maybe (ByteString -> Either String a)++ handleCTypeH :: Proxy list+ -> ByteString -- Content-Type header+ -> ByteString -- Request body+ -> Maybe (Either String a)+ handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH++instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where+ canHandleCTypeH p ctypeH =+ M.mapContentMedia (allMimeUnrender p) (toStrict ctypeH)++--------------------------------------------------------------------------+-- * Utils (Internal)++class AllMime (list :: [Type]) where+ allMime :: Proxy list -> [M.MediaType]++instance AllMime '[] where+ allMime _ = []++instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where+ allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps+ where+ pctyp = Proxy :: Proxy ctyp+ pctyps = Proxy :: Proxy ctyps++canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool+canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h++--------------------------------------------------------------------------+-- Check that all elements of list are instances of MimeRender+--------------------------------------------------------------------------+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+ allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp+ where+ bs = mimeRender pctyp a+ pctyp = Proxy :: Proxy ctyp++instance {-# OVERLAPPABLE #-}+ ( MimeRender ctyp a+ , AllMimeRender (ctyp' ': ctyps) a+ ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where+ allMimeRender _ a =+ map (, bs) (NE.toList $ contentTypes pctyp)+ ++ allMimeRender pctyps a+ where+ bs = mimeRender pctyp a+ pctyp = Proxy :: Proxy ctyp+ pctyps = Proxy :: Proxy (ctyp' ': ctyps)+++-- 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 _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp+ where+ pctyp = Proxy :: Proxy ctyp++instance {-# OVERLAPPING #-}+ ( AllMime (ctyp ': ctyp' ': ctyps)+ ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where+ allMimeRender p _ = map (, "") (allMime p)++--------------------------------------------------------------------------+-- Check that all elements of list are instances of MimeUnrender+--------------------------------------------------------------------------+class (AllMime list) => AllMimeUnrender (list :: [Type]) a where+ allMimeUnrender :: Proxy list+ -> [(M.MediaType, ByteString -> Either String a)]++instance AllMimeUnrender '[] a where+ allMimeUnrender _ = []++instance ( MimeUnrender ctyp a+ , AllMimeUnrender ctyps a+ ) => AllMimeUnrender (ctyp ': ctyps) a where+ allMimeUnrender _ =+ map mk (NE.toList $ contentTypes pctyp)+ ++ allMimeUnrender pctyps+ where+ mk ct = (ct, mimeUnrenderWithType pctyp ct)+ pctyp = Proxy :: Proxy ctyp+ pctyps = Proxy :: Proxy ctyps++--------------------------------------------------------------------------+-- * MimeRender Instances++-- | `encode`+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 #-}+ ToForm a => MimeRender FormUrlEncoded a where+ mimeRender _ = urlEncodeAsForm++-- | `TextL.encodeUtf8`+instance MimeRender PlainText TextL.Text where+ mimeRender _ = TextL.encodeUtf8++-- | @fromStrict . TextS.encodeUtf8@+instance MimeRender PlainText TextS.Text where+ mimeRender _ = fromStrict . TextS.encodeUtf8++-- | @BC.pack@+instance MimeRender PlainText String where+ mimeRender _ = TextL.encodeUtf8 . TextL.pack++-- | @id@+instance MimeRender OctetStream ByteString where+ mimeRender _ = id++-- | `fromStrict`+instance MimeRender OctetStream BS.ByteString where+ mimeRender _ = fromStrict++-- | A type for responses without content-body.+data NoContent = NoContent+ deriving (Show, Eq, Read, Generic)++instance NFData NoContent+++--------------------------------------------------------------------------+-- * MimeUnrender Instances++-- | Deprecated: since aeson version 0.9 `eitherDecode` has lenient behavior.+--+eitherDecodeLenient :: FromJSON a => ByteString -> Either String a+eitherDecodeLenient = eitherDecode+{-# DEPRECATED eitherDecodeLenient "use eitherDecode instead" #-}++-- | `eitherDecode`+instance FromJSON a => MimeUnrender JSON a where+ mimeUnrender _ = eitherDecode++-- | @urlDecodeAsForm@+-- 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 FromForm a => MimeUnrender FormUrlEncoded a where+ mimeUnrender _ = left TextS.unpack . urlDecodeAsForm++-- | @left show . TextL.decodeUtf8'@+instance MimeUnrender PlainText TextL.Text where+ mimeUnrender _ = left show . TextL.decodeUtf8'++-- | @left show . TextS.decodeUtf8' . toStrict@+instance MimeUnrender PlainText TextS.Text where+ mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict++-- | @Right . BC.unpack@+instance MimeUnrender PlainText String where+ mimeUnrender _ = bimap show TextL.unpack . TextL.decodeUtf8'++-- | @Right . id@+instance MimeUnrender OctetStream ByteString where+ 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+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XOverloadedStrings+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> instance ToJSON Book where { toJSON = undefined }
+ src/Servant/API/Description.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Description (+ -- * Combinators+ Description,+ Summary,+ -- * Used as modifiers+ FoldDescription,+ FoldDescription',+ reflectDescription,+ ) where++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:+--+-- >>> type MyApi = Summary "Get book by ISBN." :> "books" :> Capture "isbn" Text :> Get '[JSON] Book+data Summary (sym :: Symbol)+ deriving (Typeable)++-- | Add more verbose description for (part of) API.+--+-- Example:+--+-- >>> :{+--type MyApi = Description+-- "This comment is visible in multiple Servant interpretations \+-- \and can be really long if necessary. \+-- \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+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> instance ToJSON Book where { toJSON = undefined }+-- >>> data SourceFile+-- >>> instance ToJSON SourceFile where { toJSON = undefined }
+ src/Servant/API/Empty.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Empty(EmptyAPI(..)) where++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+-- treat 'EmptyAPI' as close to the unit as possible.+data EmptyAPI = EmptyAPI deriving (Typeable, Eq, Show, Bounded, Enum)
+ src/Servant/API/Experimental/Auth.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-# LANGUAGE PolyKinds #-}+module Servant.API.Experimental.Auth where++import Data.Typeable+ (Typeable)++-- | A generalized Authentication combinator. Use this if you have a+-- non-standard authentication technique.+--+-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE.+data AuthProtect (tag :: k) deriving (Typeable)
+ 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
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Header (+ Header, Header',+ ) where++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:+--+-- >>> newtype Referer = Referer Text deriving (Eq, Show)+-- >>>+-- >>> -- GET /view-my-referer+-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer+type Header = Header' '[Optional, Strict]++data Header' (mods :: [Type]) (sym :: Symbol) (a :: Type)+ deriving Typeable++-- $setup+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text
+ 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
@@ -0,0 +1,20 @@+module Servant.API.HttpVersion+ ( -- $httpversion+ HttpVersion(..)+ ) where++import Network.HTTP.Types+ (HttpVersion (..))++-- $httpversion+--+-- | You can directly use the 'HttpVersion' type from @Network.HTTP.Types@+-- if your request handlers need it to compute a response. This would+-- make the request handlers take an argument of type 'HttpVersion'.+--+-- Example:+--+-- >>> type API = HttpVersion :> Get '[JSON] String++-- $setup+-- >>> import Servant.API
+ src/Servant/API/IsSecure.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+module Servant.API.IsSecure+ ( -- $issecure+ IsSecure(..)+ ) where++import Data.Typeable+ (Typeable)+import GHC.Generics+ (Generic)++-- | Was this request made over an SSL connection?+--+-- Note that this value will not tell you if the client originally+-- made this request over SSL, but rather whether the current+-- connection is SSL. The distinction lies with reverse proxies.+-- In many cases, the client will connect to a load balancer over SSL,+-- but connect to the WAI handler without SSL. In such a case,+-- the handlers would get 'NotSecure', but from a user perspective,+-- there is a secure connection.+data IsSecure = Secure -- ^ the connection to the server+ -- is secure (HTTPS)+ | NotSecure -- ^ the connection to the server+ -- is not secure (HTTP)+ deriving (Eq, Show, Read, Generic, Ord, Typeable)++-- $issecure+--+-- | Use 'IsSecure' whenever your request handlers need to know whether+-- the connection to the server is secure or not.+-- This would make the request handlers receive an argument of type 'IsSecure',+-- whose value can be one of 'Secure' (HTTPS) or 'NotSecure' (HTTP).+--+-- Example:+--+-- >>> type API = "sensitive-data" :> IsSecure :> Get '[JSON] NationSecrets++-- $setup+-- >>> import Servant.API+-- >>> data NationSecrets
+ 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
@@ -0,0 +1,59 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}++{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where++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@.+--+-- Example:+--+-- >>> -- /books?author=<author name>+-- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]+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+-- and try to extract it as a value of type @[a]@. This is typically+-- meant to support query string parameters of the form+-- @param[]=val1¶m[]=val2@ and so on. Note that servant doesn't actually+-- require the @[]@s and will fetch the values just fine with+-- @param=val1¶m=val2@, too.+--+-- Example:+--+-- >>> -- /books?authors[]=<author1>&authors[]=<author2>&...+-- >>> type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]+data QueryParams (sym :: Symbol) (a :: Type)+ deriving Typeable++-- | Lookup a potentially value-less query string parameter+-- with boolean semantics. If the param @sym@ is there without any value,+-- or if it's there with value "true" or "1", it's interpreted as 'True'.+-- Otherwise, it's interpreted as 'False'.+--+-- Example:+--+-- >>> -- /books?published+-- >>> type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]+data QueryFlag (sym :: Symbol)++-- $setup+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> instance ToJSON Book where { toJSON = undefined }
+ 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
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Raw where++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 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
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Servant.API.RemoteHost+ ( -- $remotehost+ RemoteHost+ ) where++import Data.Typeable+ (Typeable)++-- | Provides access to the host or IP address+-- from which the HTTP request was sent.+data RemoteHost deriving Typeable++-- $remotehost+--+-- Use 'RemoteHost' whenever your request handlers need the host or IP address+-- from which the client issued the HTTP request. The corresponding handlers+-- receive arguments of type @SockAddr@ (from @Network.Socket@).+--+-- Example:+--+-- >>> -- POST /record-ip+-- >>> type API = "record-ip" :> RemoteHost :> Post '[] ()++-- $setup+-- >>> import Servant.API
+ src/Servant/API/ReqBody.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.ReqBody (+ ReqBody, ReqBody',+ ) where++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+type ReqBody = ReqBody' '[Required, Strict]++-- |+--+-- /Note:/ 'ReqBody'' is always 'Required'.+data ReqBody' (mods :: [Type]) (contentTypes :: [Type]) (a :: Type)+ deriving (Typeable)++-- $setup+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> instance ToJSON Book where { toJSON = undefined }
+ src/Servant/API/ResponseHeaders.hs view
@@ -0,0 +1,266 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | This module provides facilities for adding headers to a response.+--+-- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int+--+-- The value is added to the header specified by the type (@Location@ in the+-- example above).+module Servant.API.ResponseHeaders+ ( Headers(..)+ , ResponseHeader (..)+ , AddHeader+ , addHeader+ , addHeader'+ , noHeader+ , noHeader'+ , HasResponseHeader+ , lookupResponseHeader+ , BuildHeadersTo(buildHeadersTo)+ , GetHeaders(getHeaders)+ , GetHeaders'+ , HeaderValMap+ , HList(..)+ ) where++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 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 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'.+data Headers ls a = Headers { getResponse :: a+ -- ^ The underlying value of a 'Headers'+ , getHeadersHList :: HList ls+ -- ^ HList of headers.+ } deriving (Functor)++instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where+ rnf (Headers x hdrs) = rnf x `seq` rnf hdrs++data ResponseHeader (sym :: Symbol) a+ = Header a+ | MissingHeader+ | UndecodableHeader ByteString+ deriving (Typeable, Eq, Show, Functor)++instance NFData a => NFData (ResponseHeader sym a) where+ rnf MissingHeader = ()+ rnf (UndecodableHeader bs) = rnf bs+ rnf (Header x) = rnf x++data HList a where+ HNil :: HList '[]+ HCons :: ResponseHeader h x -> HList xs -> HList (Header' mods h x ': xs)++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' mods h x ': xs) = Header' mods h (f x) ': HeaderValMap f xs+++class BuildHeadersTo hs where+ buildHeadersTo :: [HTTP.Header] -> HList hs++instance {-# OVERLAPPING #-} BuildHeadersTo '[] where+ buildHeadersTo _ = HNil++-- The current implementation does not manipulate HTTP header field lines in any way,+-- like merging field lines with the same field name in a single line.+instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )+ => BuildHeadersTo (Header' mods h v ': xs) where+ buildHeadersTo headers = case L.find wantedHeader headers of+ Nothing -> MissingHeader `HCons` buildHeadersTo headers+ Just header@(_, val) -> case parseHeader val of+ Left _err -> UndecodableHeader val `HCons` buildHeadersTo (L.delete header headers)+ Right h -> Header h `HCons` buildHeadersTo (L.delete header headers)+ where wantedHeader (h, _) = h == wantedHeaderName+ wantedHeaderName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)++-- * Getting headers++class GetHeaders ls where+ getHeaders :: ls -> [HTTP.Header]++-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance+class GetHeadersFromHList hs where+ getHeadersFromHList :: HList hs -> [HTTP.Header]++instance GetHeadersFromHList hs => GetHeaders (HList hs) where+ getHeaders = getHeadersFromHList++instance GetHeadersFromHList '[] where+ getHeadersFromHList _ = []++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)++-- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance+class GetHeaders' hs where+ getHeaders' :: Headers hs a -> [HTTP.Header]++instance GetHeaders' hs => GetHeaders (Headers hs a) where+ getHeaders = getHeaders'++-- | This instance is an optimisation+instance GetHeaders' '[] where+ getHeaders' _ = []++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)++-- 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 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+-- existing list:+--+-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String;+-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String+-- >>> getHeaders example2+-- [("1st","true"),("someheader","5")]+--+-- 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 '[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 '[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+-- >>> data Book+-- >>> instance ToJSON Book where { toJSON = undefined }
+ 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
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Sub ((:>)) where++import Data.Kind+ (Type)+import Data.Typeable+ (Typeable)++-- | The contained API (second argument) can be found under @("/" ++ path)@+-- (path being the first argument).+--+-- Example:+--+-- >>> -- GET /hello/world+-- >>> -- returning a JSON encoded World value+-- >>> type MyApi = "hello" :> "world" :> Get '[JSON] World+data (path :: k) :> (a :: Type)+ deriving (Typeable)+infixr 4 :>++-- $setup+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data World+-- >>> instance ToJSON World where { toJSON = undefined }
+ 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
@@ -0,0 +1,317 @@+{-# 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.++The code samples in this module use the following type synonym:++> type SampleAPI = "hello" :> Get '[JSON] Int+> :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool++-}+module Servant.API.TypeLevel (+ -- $setup+ -- * API predicates+ Endpoints,+ -- ** Lax inclusion+ IsElem',+ IsElem,+ IsSubAPI,+ AllIsElem,+ -- ** Strict inclusion+ IsIn,+ IsStrictSubAPI,+ AllIsIn,+ -- * Helpers+ -- ** Lists+ MapSub,+ AppendList,+ IsSubList,+ Elem,+ ElemGo,+ -- ** Logic+ Or,+ And,+ -- ** Fragment+ FragmentUnique,+ AtMostOneFragment+ ) where+++import GHC.Exts+ (Constraint)+import Data.Kind+ (Type)+import Servant.API.Alternative+ (type (:<|>))+import Servant.API.Capture+ (Capture, CaptureAll)+import Servant.API.Fragment+import Servant.API.Header+ (Header, Header')+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)++++-- * API predicates++-- | Flatten API into a list of endpoints.+--+-- >>> Refl :: Endpoints SampleAPI :~: '["hello" :> Verb 'GET 200 '[JSON] Int, "bye" :> (Capture "name" String :> Verb 'POST 200 '[JSON, PlainText] Bool)]+-- Refl+type family Endpoints api where+ Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b)+ Endpoints (e :> a) = MapSub e (Endpoints a)+ Endpoints a = '[a]++-- ** Lax inclusion++-- | You may use this type family to tell the type checker that your custom+-- type may be skipped as part of a link. This is useful for things like+-- @'QueryParam'@ that are optional in a URI and do not affect them if they are+-- omitted.+--+-- >>> data CustomThing+-- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s+--+-- Note that @'IsElem'@ is called, which will mutually recurse back to @'IsElem''@+-- if it exhausts all other options again.+--+-- Once you have written a @HasLink@ instance for @CustomThing@ you are ready to go.+type family IsElem' a s :: Constraint++-- | Closed type family, check if @endpoint@ is within @api@.+-- Uses @'IsElem''@ if it exhausts all other options.+--+-- >>> ok (Proxy :: Proxy (IsElem ("hello" :> Get '[JSON] Int) SampleAPI))+-- OK+--+-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))+-- ...+-- ... Could not ...+-- ...+--+-- An endpoint is considered within an api even if it is missing combinators+-- that don't affect the URL:+--+-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))+-- OK+--+-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (ReqBody '[JSON] Bool :> Get '[JSON] Int)))+-- OK+--+-- *N.B.:* @IsElem a b@ can be seen as capturing the notion of whether the URL+-- represented by @a@ would match the URL represented by @b@, *not* whether a+-- request represented by @a@ matches the endpoints serving @b@ (for the+-- latter, use 'IsIn').+type family IsElem endpoint api :: Constraint where+ 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+ IsElem (Capture z y :> sa) (Capture x y :> sb)+ = IsElem sa sb+ 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@.+--+-- >>> ok (Proxy :: Proxy (IsSubAPI SampleAPI (SampleAPI :<|> Get '[JSON] Int)))+-- OK+--+-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))+-- ...+-- ... Could not ...+-- ...+--+-- This uses @IsElem@ for checking; thus the note there applies here.+type family IsSubAPI sub api :: Constraint where+ IsSubAPI sub api = AllIsElem (Endpoints sub) api++-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsElem'@).+type family AllIsElem xs api :: Constraint where+ AllIsElem '[] api = ()+ AllIsElem (x ': xs) api = (IsElem x api, AllIsElem xs api)++-- ** Strict inclusion++-- | Closed type family, check if @endpoint@ is exactly within @api@.+--+-- >>> ok (Proxy :: Proxy (IsIn ("hello" :> Get '[JSON] Int) SampleAPI))+-- OK+--+-- Unlike 'IsElem', this requires an *exact* match.+--+-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))+-- ...+-- ... Could not ...+-- ...+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@.+--+-- Like 'IsSubAPI', but uses 'IsIn' rather than 'IsElem'.+type family IsStrictSubAPI sub api :: Constraint where+ IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api++-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@).+--+-- >>> ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI))+-- OK+type family AllIsIn xs api :: Constraint where+ AllIsIn '[] api = ()+ AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api)++-- * Helpers++-- ** Lists++-- | Apply @(e :>)@ to every API in @xs@.+type family MapSub e xs where+ MapSub e '[] = '[]+ MapSub e (x ': xs) = (e :> x) ': MapSub e xs++-- | Append two type-level lists.+type family AppendList xs ys where+ AppendList '[] ys = ys+ AppendList (x ': xs) ys = x ': AppendList xs ys++type family IsSubList a b :: Constraint where+ IsSubList '[] b = ()+ IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y++-- | Check that a value is an element of a list:+--+-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))+-- OK+--+-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool]))+-- ...+-- ... [Char]...'[Int, Bool...+-- ...+type Elem e es = ElemGo e es es++-- 'orig' is used to store original list for better error messages+type family ElemGo e es orig :: Constraint where+ ElemGo x (x ': xs) orig = ()+ ElemGo y (x ': xs) orig = ElemGo y xs orig+ -- Note [Custom Errors]+ ElemGo x '[] orig = TypeError ('ShowType x+ ':<>: 'Text " expected in list "+ ':<>: 'ShowType orig)++-- ** Logic++-- | 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.+type family And (a :: Constraint) (b :: Constraint) :: Constraint where+ And () () = ()++{- 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+-- >>> data OK ctx where OK :: ctx => OK ctx+-- >>> 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
@@ -0,0 +1,21 @@+module Servant.API.Vault+ ( -- $vault+ Vault+ ) where++import Data.Vault.Lazy+ (Vault)++-- $vault+--+-- | Use 'Vault' in your API types to provide access to the 'Vault'+-- of the request, which is a location shared by middlewares and applications+-- to store arbitrary data. See <https://hackage.haskell.org/package/vault vault>+-- for more details on how to actually use the vault in your handlers+--+-- Example:+--+-- >>> type API = Vault :> Get '[JSON] String++-- $setup+-- >>> import Servant.API
+ src/Servant/API/Verbs.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++{-# LANGUAGE PolyKinds #-}+module Servant.API.Verbs+ ( module Servant.API.Verbs+ , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH)+ ) where++import Data.Kind+ (Type)+import Data.Proxy+ (Proxy)+import Data.Typeable+ (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 :: [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.+-- When appropriate, you should prefer the more specific success combinators.+-- More information about the definitions of status codes can be found in+-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC2615> and+-- <https://tools.ietf.org/html/rfc7231#section-6 RFC7231 Section 6>;+-- the relevant information is summarily presented here.++-- | 'GET' with 200 status code.+type Get = Verb 'GET 200+-- | 'POST' with 200 status code.+type Post = Verb 'POST 200+-- | 'PUT' with 200 status code.+type Put = Verb 'PUT 200+-- | 'DELETE' with 200 status code.+type Delete = Verb 'DELETE 200+-- | 'PATCH' with 200 status code.+type Patch = Verb 'PATCH 200++-- * Other responses++-- ** 201 Created+--+-- 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.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+--+-- Indicates that the request has been accepted for processing, but the+-- processing has not yet completed. The status of the processing should be+-- included, as well as either a link to a status monitoring endpoint or an+-- estimate of when the processing will be finished.++-- | 'GET' with 202 status code.+type GetAccepted = Verb 'GET 202+-- | 'POST' with 202 status code.+type PostAccepted = Verb 'POST 202+-- | 'DELETE' with 202 status code.+type DeleteAccepted = Verb 'DELETE 202+-- | 'PATCH' with 202 status code.+type PatchAccepted = Verb 'PATCH 202+-- | 'PUT' with 202 status code.+type PutAccepted = Verb 'PUT 202+++-- ** 203 Non-Authoritative Information+--+-- Indicates that the request has been successfully processed, but the+-- information may come from a third-party.++-- | 'GET' with 203 status code.+type GetNonAuthoritative = Verb 'GET 203+-- | 'POST' with 203 status code.+type PostNonAuthoritative = Verb 'POST 203+-- | 'DELETE' with 203 status code.+type DeleteNonAuthoritative = Verb 'DELETE 203+-- | 'PATCH' with 203 status code.+type PatchNonAuthoritative = Verb 'PATCH 203+-- | 'PUT' with 203 status code.+type PutNonAuthoritative = Verb 'PUT 203+++-- ** 204 No Content+--+-- Indicates that no response body is being returned. Handlers for these should+-- return 'NoContent', possibly with headers.+--+-- If the document view should be reset, use @205 Reset Content@.++-- | 'GET' with 204 status code.+type GetNoContent = NoContentVerb 'GET+-- | 'POST' with 204 status code.+type PostNoContent = NoContentVerb 'POST+-- | 'DELETE' with 204 status code.+type DeleteNoContent = NoContentVerb 'DELETE+-- | 'PATCH' with 204 status code.+type PatchNoContent = NoContentVerb 'PATCH+-- | 'PUT' with 204 status code.+type PutNoContent = NoContentVerb 'PUT+-- | 'HEAD' with 204 status code.+type HeadNoContent = NoContentVerb 'HEAD++-- ** 205 Reset Content+--+-- Indicates that no response body is being returned. Handlers for these should+-- return 'NoContent', possibly with Headers.+--+-- If the document view should not be reset, use @204 No Content@.++-- | 'GET' with 205 status code.+type GetResetContent = Verb 'GET 205+-- | 'POST' with 205 status code.+type PostResetContent = Verb 'POST 205+-- | 'DELETE' with 205 status code.+type DeleteResetContent = Verb 'DELETE 205+-- | 'PATCH' with 205 status code.+type PatchResetContent = Verb 'PATCH 205+-- | 'PUT' with 205 status code.+type PutResetContent = Verb 'PUT 205+++-- ** 206 Partial Content+--+-- Indicates that the server is delivering part of the resource due to a range+-- header in the request.+--+-- For more information, see <https://tools.ietf.org/html/rfc7233#section-4.1+-- RFC7233 Section 4.1>++-- | 'GET' with 206 status code.+type GetPartialContent = Verb 'GET 206+++class ReflectMethod a where+ reflectMethod :: Proxy a -> Method++instance ReflectMethod 'GET where+ reflectMethod _ = methodGet++instance ReflectMethod 'POST where+ reflectMethod _ = methodPost++instance ReflectMethod 'PUT where+ reflectMethod _ = methodPut++instance ReflectMethod 'DELETE where+ reflectMethod _ = methodDelete++instance ReflectMethod 'PATCH where+ reflectMethod _ = methodPatch++instance ReflectMethod 'HEAD where+ reflectMethod _ = methodHead++instance ReflectMethod 'OPTIONS where+ reflectMethod _ = methodOptions++instance ReflectMethod 'TRACE where+ reflectMethod _ = methodTrace++instance ReflectMethod 'CONNECT where+ reflectMethod _ = methodConnect
+ src/Servant/API/WithNamedContext.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module Servant.API.WithNamedContext where++import GHC.TypeLits+import Data.Kind+ (Type)++-- | 'WithNamedContext' names a specific tagged context to use for the+-- combinators in the API. (See also in @servant-server@,+-- @Servant.Server.Context@.) For example:+--+-- > type UseNamedContextAPI = WithNamedContext "myContext" '[String] (+-- > ReqBody '[JSON] Int :> Get '[JSON] Int)+--+-- Both the 'ReqBody' and 'Get' combinators will use the 'WithNamedContext' with+-- type tag "myContext" as their context.+--+-- 'Context's are only relevant for @servant-server@.+--+-- For more information, see the tutorial.+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/Context.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{- |-Module : Servant.Context-Copyright : (c) Zalora SEA 2014-License : BSD3-Maintainer : Alp Mestanogullari <alp@zalora.com>-Stability : experimental--A 'Context' type for holding a function-that will use some /context/ to execute-something analoguous to a /database operation/.--This is equivalent to holding something like:--> withConnection someConnection--where you have previously set up @someConnection@ by specifying a-connection string or something like that. This lets us support-any kind of backend (even an in-memory Map in an /IORef/), and-most interestingly, we can use just raw connections or a connection-pool, this approach really covers a lot of situations while keeping-everything quite simple.---}-module Servant.Context- ( Context- , mkContext- , withContext- ) where---- | A 'Context' is just a wrapper around a function--- that can execute IO operations /given/--- this context.-newtype Context c- = Context { withctx :: forall r. (c -> IO r) -> IO r }---- | Create a 'Context' from a suitable function-mkContext :: (forall r. (c -> IO r) -> IO r)- -> Context c-mkContext = Context---- | Use the 'Context' to actually perform an 'IO'--- operation requiring it.-withContext :: Context c- -> (c -> IO r)- -> IO r-withContext = withctx
− src/Servant/Error.hs
@@ -1,94 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{- |-Module : Servant.Error-Copyright : (c) Zalora SEA 2014-License : BSD3-Maintainer : Alp Mestanogullari <alp@zalora.com>-Stability : experimental--Everything you'll need when doing some kind of exception handling-around your \"database operations\".--}-module Servant.Error- ( -- * Creating an combining 'ExceptionCatcher's- ExceptionCatcher- , noCatch- , catchAnd- , combineCatchers-- , -- * Running 'IO' actions against an 'ExceptionCatcher'- handledWith- ) where--import Control.Exception-import Data.Monoid---- | A container for zero or more "exception catchers".------ By exception catcher, we mean here a function that can convert--- some precise instance of 'Exception' to the error type used in--- your scotty app (the @e@ type in "Servant.Resource" "Servant.Service")-newtype ExceptionCatcher err =- EC [Catcher err]---- a handy type for representing a single function that can catch--- some (specific) exception.--- The dictionary for the corresponding 'Exception' instance is packed--- along with the function in this data type.-data Catcher err = forall exc. Exception exc => Catcher (exc -> err)---- | Don't catch any exception.-noCatch :: ExceptionCatcher err-noCatch = EC []---- | Combine two 'ExceptionCatcher'.------ The resulting 'ExceptionCatcher' will be able to catch--- exceptions using the /catchers/ from both arguments.-combineCatchers :: ExceptionCatcher err- -> ExceptionCatcher err- -> ExceptionCatcher err-combineCatchers (EC c1s) (EC c2s) = EC (c1s ++ c2s)---- | If you're into 'Monoid's, enjoy our--- 'mempty' ('noErrorHandling') and '<>' ('combineCatchers').-instance Monoid (ExceptionCatcher err) where- mempty = noCatch-- mappend = combineCatchers---- | Run an 'IO' action by watching for all the exceptions--- supported by the 'ExceptionCatcher'.------ If an exception is thrown somewhere in the action and is caught--- by the catcher, it will call the function given to 'catchAnd'--- to convert the exception value to the error type of your scotty application.------ If an exception is thrown whose type isn't one for which there's a /catcher/--- in the 'ExceptionCatcher' argument, you'll have to catch it yourself or let it--- be sent to the default handler.------ Since 'Servant.Service.runService' sets up a 'defaultHandler', you'll most--- likely want to directly use 'raiseIfExc' which 'raise's the error value--- you got from the exception if some exception is thrown or just run some--- scotty action if everything went smoothly. This means writing a handler--- that'll set up a response with the proper HTTP status and send some JSON--- to the client with an informative error message, which... isn't a bad thing :-)-handledWith :: IO a -> ExceptionCatcher err -> IO (Either err a)-handledWith act (EC hs) = fmap Right act `catches` map runCatcher hs-- where runCatcher :: Catcher err -> Handler (Either err a)- runCatcher (Catcher f) = Handler $ return . Left . f---- | Create an 'ExceptionCatcher' from a function.------ This will make the catcher aware of exceptions of type @except@--- so that when you'll run a catcher against an 'IO' action--- using 'raiseIfExc' or 'handledWith', if an exception of this type--- is thrown, it will be caught and converted to the error type of your--- web application using the provided function.-catchAnd :: Exception except- => (except -> err) - -> ExceptionCatcher err-catchAnd f = EC [catcher]- where catcher = Catcher f
+ 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/Prelude.hs
@@ -1,163 +0,0 @@-{-# LANGUAGE TypeOperators,- ConstraintKinds,- MultiParamTypeClasses,- TypeFamilies,- TypeSynonymInstances,- DataKinds,- FlexibleContexts,- FlexibleInstances,- ScopedTypeVariables #-}-{- |-Module : Servant.Prelude-Copyright : (c) Zalora SEA 2014-License : BSD3-Maintainer : Alp Mestanogullari <alp@zalora.com>-Stability : experimental--Some standard REST-y operations your 'Resource's can-support out of the box.--Your type will have to implement a couple of class instances-to be usable with a backend. For the scotty backend, this means-having 'FromJSON' or 'ToJSON' instances and the appropriate-'toResponse' implementations for the return types of your-database.--}-module Servant.Prelude- ( -- * Defining 'Resource's- module Servant.Resource- , module Servant.Context- , module Servant.Error- - , -- * Standard operations- Add- , addWith- , Delete- , deleteWith- , ListAll- , listAllWith- , Update- , updateWith- , View- , viewWith- ) where--import Servant.Context-import Servant.Error-import Servant.Resource---- | A dummy type representing an operation that adds an entry.-data Add-instance Show Add where show _ = "Add"---- | A dummy type representing an operation that deletes an entry.-data Delete-instance Show Delete where show _ = "Delete"---- | A dummy type representing an operation that lists all entries.-data ListAll-instance Show ListAll where show _ = "ListAll"---- | A dummy type representing an operation that updates an entry.-data Update-instance Show Update where show _ = "Update"---- | A dummy type representing an operation that looks up an entry.-data View-instance Show View where show _ = "View"---- | To 'Add' an entry, we require a function of type @c -> a -> IO r@.-type instance Operation Add c a i r = a -> c -> IO (r Add)--- | To 'Delete' an entry, we require a function of type @c -> i -> IO r@.-type instance Operation Delete c a i r = i -> c -> IO (r Delete)--- | To 'List' all entries, we require a function of type @c -> IO [a]@.-type instance Operation ListAll c a i r = c -> IO [a]--- | To 'Update' an entry, we require a function of type @c -> i -> a -> IO r@.-type instance Operation Update c a i r = i -> a -> c -> IO (r Update)--- | To 'View' an entry, we require a function of type @c -> i -> IO (Maybe a)@.-type instance Operation View c a i r = i -> c -> IO (Maybe a)---- | Make a 'Resource' support the 'Add'--- operation by using your function.------ Given:------ > addPerson :: PGSQL.Connection -> Person -> IO Bool------ you could do:------ > mkResource "persons" postgresContext noErrorHandling--- > & addWith addPerson-addWith :: Contains Add ops ~ False- => (a -> c -> IO (r Add))- -> Resource c a i r e ops- -> Resource c a i r e (Add ': ops)-addWith = addOperation---- | Make a 'Resource' support the 'Delete'--- operation by using your function.------ Given:------ > deletePerson :: PGSQL.Connection -> PersonId -> IO Bool------ you could do:------ > mkResource "persons" postgresContext noErrorHandling--- > & deleteWith addPerson-deleteWith :: Contains Delete ops ~ False- => (i -> c -> IO (r Delete))- -> Resource c a i r e ops- -> Resource c a i r e (Delete ': ops)-deleteWith = addOperation---- | Make a 'Resource' support the 'ListAll'--- operation by using your function.------ Given:------ > listAllPersons :: PGSQL.Connection -> IO [Person]------ you could do:------ > mkResource "persons" postgresContext noErrorHandling--- > & listAllWith listAllPersons-listAllWith :: Contains ListAll ops ~ False- => (c -> IO [a])- -> Resource c a i r e ops- -> Resource c a i r e (ListAll ': ops)-listAllWith = addOperation---- | Make a 'Resource' support the 'Update'--- operation by using your function.------ Given:------ > updatePerson :: PGSQL.Connection -> PersonId -> Person -> IO Bool------ you could do:------ > mkResource "persons" postgresContext noErrorHandling--- > & updateWith updatePerson-updateWith :: Contains Update ops ~ False- => (i -> a -> c -> IO (r Update))- -> Resource c a i r e ops- -> Resource c a i r e (Update ': ops)-updateWith = addOperation---- | Make a 'Resource' support the 'View'--- operation by using your function.------ Given:------ > viewPerson :: PGSQL.Connection -> PersonId -> IO (Maybe Person)------ you could do:------ > mkResource "persons" postgresContext noErrorHandling--- > & viewWith viewPerson-viewWith :: Contains View ops ~ False- => (i -> c -> IO (Maybe a))- -> Resource c a i r e ops- -> Resource c a i r e (View ': ops)-viewWith = addOperation
− src/Servant/Resource.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--{- |-Module : Servant.Resource-Copyright : (c) Zalora SEA 2014-License : BSD3-Maintainer : Alp Mestanogullari <alp@zalora.com>-Stability : experimental--Defining 'Resource's.--}-module Servant.Resource- ( Resource- , name- , context- , excCatcher- , withHeadOperation- , dropHeadOperation- , mkResource- , addOperation- , Operation- , (&)- , Ops- , Contains- ) where--import Servant.Context-import Servant.Error---- | Heterogeneous list-data HList :: [*] -> * where- Nil :: HList '[]- Cons :: a -> HList as -> HList (a ': as)--hhead :: HList (a ': as) -> a-hhead (Cons h _) = h---- | Get the tail of an heterogeneous list-htail :: HList (a ': as) -> HList as-htail (Cons _ t) = t---- | Utility (closed) type family to detect whether a type--- is contained in a type-level list of types-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 781-type family Contains (elem :: *) (list :: [*]) :: Bool where- Contains elem '[] = False- Contains elem (elem ': xs) = True- Contains elem (x ': xs) = Contains elem xs-#else-type Contains (elem :: *) (list :: [*]) = False-#endif---- | A resource that:------ * uses some context type @c@ (think database connection)--- * manages entries of type @a@--- * (optionally) supports indexing through the @i@ type (a dumb ID, or something like--- @data FooId = ByToken Token | ByID Integer@). That can be useful when trying to view,--- update or delete a particular entry, for example.--- * uses @r@ as the return type (tagged by the operation type) for /effectful/ database operations (e.g. adding, updating, deleting entries--- for example).--- * can catch exceptions, converting them to some error type--- @e@ of yours--- * supports the operations listed in the @ops@ type list. a corresponding--- (heterogeneous) list of "database functions" is held internally and we--- ask the compiler to make the types of these functions match with the ones--- expected for the operations listed at the type-level.-data Resource c a i (r :: * -> *) e (ops :: [*])- = Resource { name :: String -- ^ Get the name of the 'Resource'- , context :: Context c -- ^ Gives the 'Context' attached to this 'Resource'- , excCatcher :: ExceptionCatcher e -- ^ Hands you the 'ExceptionCatcher' you can- -- 'handledWith' with to make your \"database operations\"- -- exception safe.- , operations :: HList (Ops ops c a i r)- }--instance Show (Resource c a i r e '[]) where- show r = name r--instance (Show o, Show (Resource c a i r e ops)) - => Show (Resource c a i r e (o ': ops)) where- show r = - show (dropHeadOperation r) ++- opstring-- where opstring = "\n - " ++ show (undefined :: o)---- | Typically, functions that will use our operations will need access--- to the resource's name and what not, so we need to provide them with--- the resource. But we obviously also need the \"database function\"--- associated to our operation. So we provide it too.------ Just give this function a 'Resource' and a function that uses it,--- most likely to run the handler for an operation,--- and it'll give your function the right arguments.-withHeadOperation :: Resource c a i r e (o ': ops)- -> (Resource c a i r e (o ': ops) -> Operation o c a i r -> b)- -> b-withHeadOperation res runop =- runop res (hhead $ operations res)---- | Type-safely \"unconsider\" the first operation in the list------ Helpful when performing recursion on the type-level list--- and the internal list of \"database functions\"--- simultaneously.-dropHeadOperation :: Resource c a i r e (o ': ops) -> Resource c a i r e ops-dropHeadOperation r = r { operations = operations' }-- where operations' = htail (operations r)---- | Create an /empty/ resource that doesn't support any operation--- and catches exceptions using the given 'ExceptionCatcher'.--- Any operation supported later on can make use of the provided--- 'Context', by simply doing:------ > withContext (context resource) $ \c -> ...------ where @c@ could be a PostgreSQL connection, for example.-mkResource :: String- -> Context c- -> ExceptionCatcher e- -> Resource c a i r e '[]-mkResource n ctx catcher = Resource n ctx catcher Nil---- | Add an operation to a resource by specifying the \"database function\"--- that'll actually perform the lookup, update, listing, search and what not.------ We statically enforce that the operation we're adding isn't--- already supported by the 'Resource', when built with @ghc >= 7.8@.-addOperation :: Contains o ops ~ False- => Operation o c a i r - -> Resource c a i r e ops - -> Resource c a i r e (o ': ops)-addOperation opfunc resource =- resource { operations = Cons opfunc (operations resource) }---- | Type level 'map'-like function that replaces an operation's tag--- by the type of the associated \"database function\"------ For example:------ > Ops [Add, List] c a i r------ will result in:------ > [ a -> c -> IO r -- what 'Add' is replaced by--- > , c -> IO [a] -- what 'List' is replaced by--- > ]------ This is useful as we can exactly determine the type of the heterogeneous--- list that holds the actual \"dtabase functions\" that will perform the--- operations, using 'Ops'. This among other things enforces a strong--- correspondance between the type-level list of operations and the--- (heterogeneous) list of functions held in the 'Resource' we're interested in.------ That means we can't magically convert a 'Resource' into one that supports one more--- operations without registering a function for it (which /must have/ the right type,--- or your code won't compile.-type family Ops (ops :: [*]) c a i (r :: * -> *) :: [*]-type instance Ops (o ': ops) c a i r = Operation o c a i r ': Ops ops c a i r-type instance Ops '[] c a i r = '[]---- | Map an operation tag @o@ to some combination of the other type--- parameters.------ For instance, if we look at 'Add', we know that we'll need our--- \"connection type\" @c@ and a value to add, of type @a@. The result will--- be of type @IO (r Add)@. If we put this all together, we get:------ > type instance Operation Add c a i r = a -> c -> IO (r Add)------ Whereas for listing all entries ('ListAll'), we just want some kind--- of connection @c@ and we get back @[a]@.------ > type instance Operation ListAll c a i r = c -> IO [a]-type family Operation o c a i (r :: * -> *) :: *---- | Reversed function application.------ > x & f = f x-(&) :: a -> (a -> b) -> b-x & f = f x-{-# INLINE (&) #-}
+ 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)
+ test/Servant/API/ContentTypesSpec.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.API.ContentTypesSpec where++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+ (sortBy)+import qualified Data.List.NonEmpty as NE+import Data.Maybe+ (fromJust, isJust, isNothing)+import Data.Proxy+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 "quickcheck-instances" Test.QuickCheck.Instances ()+import Text.Read+ (readMaybe)++import Servant.API.ContentTypes++spec :: Spec+spec = describe "Servant.API.ContentTypes" $ do++ describe "handleAcceptH" $ do+ let p = Proxy :: Proxy '[PlainText]++ it "matches any charset if none were provided" $ do+ let without = handleAcceptH p (AcceptHeader "text/plain")+ with = handleAcceptH p (AcceptHeader "text/plain;charset=utf-8")+ wisdom = "ubi sub ubi" :: String+ without wisdom `shouldBe` with wisdom++ it "does not match non utf-8 charsets" $ do+ let badCharset = handleAcceptH p (AcceptHeader "text/plain;charset=whoknows")+ s = "cheese" :: String+ badCharset s `shouldBe` Nothing++ describe "The JSON Content-Type type" $ do+ let p = Proxy :: Proxy JSON++ it "handles whitespace at end of input" $ do+ mimeUnrender p "[1] " `shouldBe` Right [1 :: Int]++ it "handles whitespace at beginning of input" $ do+ mimeUnrender p " [1] " `shouldBe` Right [1 :: Int]++ it "does not like junk at end of input" $ do+ mimeUnrender p "[1] this probably shouldn't work"+ `shouldSatisfy` (isLeft :: Either a [Int] -> Bool)++ it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do+ property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::[Int])++ 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++ it "has mimeUnrender reverse mimeRender (lazy Text)" $ do+ property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextL.Text)++ it "has mimeUnrender reverse mimeRender (strict Text)" $ do+ property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextS.Text)++ describe "The OctetStream Content-Type type" $ do+ let p = Proxy :: Proxy OctetStream++ it "is id (Lazy ByteString)" $ do+ property $ \x -> mimeRender p x == (x :: BSL.ByteString)+ && mimeUnrender p x == Right x++ it "is fromStrict/toStrict (Strict ByteString)" $ do+ property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString)+ && mimeUnrender p (BSL.fromStrict x) == Right x++ describe "handleAcceptH" $ do++ it "returns Nothing if the 'Accept' header doesn't match" $ do+ handleAcceptH (Proxy :: Proxy '[JSON]) "text/plain" (3 :: Int)+ `shouldSatisfy` isNothing++ it "returns Just if the 'Accept' header matches" $ do+ handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)+ `shouldSatisfy` isJust+ handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int)+ `shouldSatisfy` isJust+ handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream])+ "application/octet-stream" ("content" :: ByteString)+ `shouldSatisfy` isJust++ it "returns Just if the 'Accept' header matches, with multiple mime types" $ do+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int)+ `shouldSatisfy` isJust+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int)+ `shouldSatisfy` isJust+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int)+ `shouldBe` Nothing++ it "returns the Content-Type as the first element of the tuple" $ do+ handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)+ handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int)+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)+ handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream])+ "application/octet-stream" ("content" :: ByteString)+ `shouldSatisfy` ((== "application/octet-stream") . fst . fromJust)++ it "returns the appropriately serialized representation" $ do+ property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData)+ == Just ("application/json;charset=utf-8", encode x)++ it "respects the Accept spec ordering" $ do+ 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 ""+ let val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText])+ (acceptH a b c) (i :: Int)+ 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++ it "returns Nothing if the 'Content-Type' header doesn't match" $ do+ handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 "+ `shouldBe` (Nothing :: Maybe (Either String Value))++ context "the 'Content-Type' header matches" $ do+ it "returns Just if the parameter matches" $ do+ handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"+ "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "+ `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)++ it "returns Just if there is no parameter" $ do+ handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"+ "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "+ `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)++ it "returns Just Left if the decoding fails" $ do+ let isJustLeft :: Maybe (Either String Value) -> Bool+ isJustLeft (Just (Left _)) = True+ isJustLeft _ = False+ handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"+ "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- "+ `shouldSatisfy` isJustLeft++ it "returns Just (Right val) if the decoding succeeds" $ do+ let val = SomeData "Of cabbages--and kings" 12+ handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"+ (encode val)+ `shouldBe` Just (Right val)++ it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do+ let val = 42 :: Int+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"+ "42" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"+ "42" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"+ "42" `shouldBe` (Nothing :: Maybe (Either String Int))++ it "passes content-type to mimeUnrenderWithType" $ do+ let val = "foobar" :: TextS.Text+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"+ "\"foobar\"" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"+ "foobar" `shouldBe` Just (Right val)+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"+ "foobar" `shouldBe` (Nothing :: Maybe (Either String Int))++ 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+ property $ \x -> mimeUnrender (Proxy :: Proxy JSON) x+ `shouldBe` (eitherDecode x :: Either String String)++data SomeData = SomeData { record1 :: String, record2 :: Int }+ deriving (Generic, Eq, Show)++newtype ZeroToOne = ZeroToOne Float+ deriving (Eq, Show, Ord)++instance FromJSON SomeData++instance ToJSON SomeData++instance Arbitrary SomeData where+ arbitrary = SomeData <$> arbitrary <*> arbitrary++instance Arbitrary ZeroToOne where+ arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]++instance MimeRender OctetStream Int where+ mimeRender _ = BSL8.pack . show++instance MimeRender PlainText Int where+ mimeRender _ = BSL8.pack . show++instance MimeRender PlainText ByteString where+ mimeRender _ = BSL.fromStrict++instance ToJSON ByteString where+ toJSON x = object [ "val" .= x ]++instance IsString AcceptHeader where+ fromString = AcceptHeader . fromString++-- To test multiple content types+data JSONorText++instance Accept JSONorText where+ contentTypes _ = "text/plain" NE.:| [ "application/json" ]++instance MimeRender JSONorText Int where+ mimeRender _ = BSL8.pack . show++instance MimeUnrender JSONorText Int where+ mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack++instance MimeUnrender JSONorText TextS.Text where+ mimeUnrenderWithType _ mt+ | mt == "application/json" = maybe (Left "") Right . decode+ | otherwise = Right . TextSE.decodeUtf8 . BSL.toStrict++addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader+addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)+ where new = BS8.pack (show $ contentType p) <> "; q=" <> BS8.pack (show f)+ cont "" = new+ cont old = old <> ", " <> new
+ test/Servant/API/ResponseHeadersSpec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+module Servant.API.ResponseHeadersSpec where++import Data.Proxy+import GHC.TypeLits+import Test.Hspec++import Servant.API.ContentTypes+import Servant.API.Description+ (Description)+import Servant.API.Header+import Servant.API.Modifiers+ (Optional, Strict)+import Servant.API.ResponseHeaders+import Servant.API.UVerb++spec :: Spec+spec = describe "Servant.API.ResponseHeaders" $ do+ describe "addHeader" $ do++ it "adds a header to a value" $ do+ let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int+ getHeaders val `shouldBe` [("test", "hi")]++ it "maintains the value" $ do+ let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int+ getResponse val `shouldBe` 5++ it "adds headers to the front of the list" $ do+ 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/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}