diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,652 @@ [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 ---- -### Signifacant changes +### Significant changes - `Stream` takes a status code argument @@ -36,9 +679,9 @@ - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers - of a web application live in, we also have `hoistClient` for changing the monad + of a web application live, we also have `hoistClient` for changing the monad in which *client functions* live. - Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). + Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) iF you have own combinators, you'll need to define a new method of @@ -85,10 +728,10 @@ - Added tests or enabled tests ([#975](https://github.com/haskell-servant/servant/pull/975)) -- Add [pagination cookbook recipe](https://haskell-servant.readthedocs.io/en/release-0.14/cookbook/pagination/Pagination.html) +- Add [pagination cookbook recipe](https://docs.servant.dev/en/release-0.14/cookbook/pagination/Pagination.html) ([#946](https://github.com/haskell-servant/servant/pull/946)) -- Add [`servant-flatten` "spice" to the structuring api recipe](https://haskell-servant.readthedocs.io/en/release-0.14/cookbook/structuring-apis/StructuringApis.html) +- Add [`servant-flatten` "spice" to the structuring api recipe](https://docs.servant.dev/en/release-0.14/cookbook/structuring-apis/StructuringApis.html) ([#929](https://github.com/haskell-servant/servant/pull/929)) - Dependency updates @@ -118,7 +761,7 @@ ### Note -(VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant/pull\/\1)/` +(VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant\/pull\/\1)/` 0.13.0.1 -------- @@ -138,9 +781,9 @@ ``` See tutorial for more details - - [A web API as a type - StreamGet and StreamPost](http://haskell-servant.readthedocs.io/en/release-0.13/tutorial/ApiType.html#streamget-and-streampost) - - [Serving an API - streaming endpoints](http://haskell-servant.readthedocs.io/en/release-0.13/tutorial/Server.html#streaming-endpoints) - - [Querying an API - Querying Streaming APIs](http://haskell-servant.readthedocs.io/en/release-0.13/tutorial/Client.html#querying-streaming-apis) + - [A web API as a type - StreamGet and StreamPost](http://docs.servant.dev/en/release-0.13/tutorial/ApiType.html#streamget-and-streampost) + - [Serving an API - streaming endpoints](http://docs.servant.dev/en/release-0.13/tutorial/Server.html#streaming-endpoints) + - [Querying an API - Querying Streaming APIs](http://docs.servant.dev/en/release-0.13/tutorial/Client.html#querying-streaming-apis) - *servant* Add `Servant.API.Modifiers` ([#873](https://github.com/haskell-servant/servant/pull/873) @@ -171,7 +814,7 @@ ([#893](https://github.com/haskell-servant/servant/pull/893)) - *Cookbook* example projects at - http://haskell-servant.readthedocs.io/en/master/cookbook/index.html + http://docs.servant.dev/en/master/cookbook/index.html ([#867](https://github.com/haskell-servant/servant/pull/867) [#892](https://github.com/haskell-servant/servant/pull/882)) @@ -243,7 +886,7 @@ `enter` isn't exported from `Servant` module anymore. You can change `enter` to `hoistServer` in a straight forward way. - Unwrap natural transformation and add a api type `Proxy`: + Unwrap natural transformation and add an api type `Proxy`: ```diff -server = enter (NT nt) impl diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,31 +0,0 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain - -#endif - -\end{code} diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant.cabal b/servant.cabal --- a/servant.cabal +++ b/servant.cabal @@ -1,42 +1,82 @@ -name: servant -version: 0.14 -synopsis: A family of combinators for defining webservices APIs +cabal-version: 3.0 +name: servant +version: 0.20.3.0 +synopsis: A family of combinators for defining webservices APIs +category: Servant, Web description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . -homepage: http://haskell-servant.readthedocs.org/ -Bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Servant, Web -build-type: Custom -cabal-version: >=1.10 -tested-with: - GHC==7.8.4 - GHC==7.10.3 - GHC==8.0.2 - GHC==8.2.2 - GHC==8.4.3 -extra-source-files: - include/*.h - CHANGELOG.md + +homepage: http://docs.servant.dev/ +bug-reports: http://github.com/haskell-servant/servant/issues +license: BSD-3-Clause +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: + 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors + +build-type: Simple +tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 + +extra-source-files: CHANGELOG.md + source-repository head - type: git + type: git location: http://github.com/haskell-servant/servant.git -custom-setup - setup-depends: - base >= 4 && <5, - Cabal, - cabal-doctest >= 1.0.6 && <1.1 +common extensions + default-extensions: + AllowAmbiguousTypes + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NoStarIsType + OverloadedLabels + OverloadedStrings + PackageImports + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + default-language: Haskell2010 + +common ghc-options + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -fhide-source-paths -Wno-unused-do-bind -fdicts-strict + -Wno-unticked-promoted-constructors -Werror=unused-imports + -Wunused-packages + library + import: extensions + import: ghc-options exposed-modules: Servant.API Servant.API.Alternative @@ -46,137 +86,112 @@ Servant.API.Description Servant.API.Empty Servant.API.Experimental.Auth + Servant.API.Fragment + Servant.API.Generic Servant.API.Header + Servant.API.Host Servant.API.HttpVersion - Servant.API.Internal.Test.ComprehensiveAPI Servant.API.IsSecure Servant.API.Modifiers + Servant.API.NamedRoutes Servant.API.QueryParam + Servant.API.QueryString + Servant.API.Range Servant.API.Raw Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders + Servant.API.ServerSentEvents + Servant.API.Status Servant.API.Stream Servant.API.Sub + Servant.API.TypeErrors Servant.API.TypeLevel + Servant.API.TypeLevel.List + Servant.API.UVerb + Servant.API.MultiVerb + Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext - Servant.Utils.Links - Servant.Utils.Enter + Servant.API.WithResource + -- Types + exposed-modules: + Servant.Types.SourceT + Servant.Types.Internal.Response + + -- Test stuff + exposed-modules: Servant.Test.ComprehensiveAPI + + -- Safe links + exposed-modules: Servant.Links + -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.12 - , bytestring >= 0.10.4.0 && < 0.11 - , mtl >= 2.1 && < 2.3 - , text >= 1.2.3.0 && < 1.3 + , base >= 4.16.4.0 && <4.22 + , bytestring >=0.11 && <0.13 + , constraints >=0.2 + , containers >=0.6.5.1 && <0.9 + , mtl ^>=2.2.2 || ^>=2.3.1 + , sop-core >=0.4.0.0 && <0.6 + , generics-sop ^>=0.5.1 + , text >=1.2.3.0 && <2.2 + , transformers >=0.5.2.0 && <0.7 - if !impl(ghc >= 8.0) - build-depends: - semigroups >= 0.18.4 && < 0.19 + -- We depend (heavily) on the API of these packages: + -- i.e. re-export, or allow using without direct dependency + build-depends: + , http-api-data >=0.4.1 && <0.7 + , singleton-bool >=0.1.4 && <0.2 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - base-compat >= 0.10.1 && < 0.11 - , aeson >= 1.3.1.1 && < 1.5 - , attoparsec >= 0.13.2.2 && < 0.14 - , case-insensitive >= 1.2.0.10 && < 1.3 - , http-api-data >= 0.3.8.1 && < 0.4 - , http-media >= 0.7.1.2 && < 0.8 - , http-types >= 0.12.1 && < 0.13 - , natural-transformation >= 0.4 && < 0.5 - , mmorph >= 1.1.2 && < 1.2 - , tagged >= 0.8.5 && < 0.9 - , singleton-bool >= 0.1.4 && < 0.2 - , string-conversions >= 0.4.0.1 && < 0.5 - , network-uri >= 2.6.1.0 && < 2.7 - , vault >= 0.3.1.1 && < 0.4 + , aeson >=1.4.1.0 && <2.3 + , attoparsec >=0.13.2.2 && <0.15 + , bifunctors >=5.5.3 && <5.7 + , case-insensitive >=1.2.0.11 && <1.3 + , deepseq >=1.4.2.0 && <1.6 + , http-media >=0.7.1.3 && <0.9 + , http-types >=0.12.2 && <0.13 + , mmorph >=1.1.2 && <1.3 + , network-uri >=2.6.1.0 && <2.7 + , QuickCheck >=2.12.6.1 && <2.16 + , vault >=0.3.1.2 && <0.4 - hs-source-dirs: src - default-language: Haskell2010 - other-extensions: CPP - , ConstraintKinds - , DataKinds - , DeriveDataTypeable - , FlexibleInstances - , FunctionalDependencies - , GADTs - , KindSignatures - , MultiParamTypeClasses - , OverlappingInstances - , OverloadedStrings - , PolyKinds - , QuasiQuotes - , RecordWildCards - , ScopedTypeVariables - , TemplateHaskell - , TypeFamilies - , TypeOperators - , TypeSynonymInstances - , UndecidableInstances - ghc-options: -Wall - if impl(ghc >= 8.0) - ghc-options: -Wno-redundant-constraints - include-dirs: include + hs-source-dirs: src test-suite spec - type: exitcode-stdio-1.0 - ghc-options: -Wall - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs + import: extensions + import: ghc-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs other-modules: - Servant.API.ContentTypesSpec - Servant.API.ResponseHeadersSpec - Servant.Utils.LinksSpec - Servant.Utils.EnterSpec + Servant.API.ContentTypesSpec + Servant.API.ResponseHeadersSpec + Servant.API.StreamSpec + Servant.LinksSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: - base - , base-compat , aeson + , base , bytestring + , http-media + , mtl + , network-uri , servant - , string-conversions , text - if !impl(ghc >= 8.0) - build-depends: - semigroups - - -- Additonal dependencies - build-depends: - aeson-compat >= 0.3.7.1 && < 0.4 - , hspec >= 2.5.1 && < 2.6 - , QuickCheck >= 2.11.3 && < 2.12 - , quickcheck-instances >= 0.3.18 && < 0.4 - - build-tool-depends: - hspec-discover:hspec-discover >= 2.5.1 && < 2.6 - -test-suite doctests - build-depends: - base - , servant - , doctest >= 0.15.0 && <0.16 - - -- We test Links failure with doctest, so we need extra dependencies + -- Additional dependencies build-depends: - hspec >= 2.5.1 && < 2.6 + , hspec >=2.6.0 && <2.12 + , QuickCheck >=2.12.6.1 && <2.16 + , quickcheck-instances >=0.3.19 && <0.4 - type: exitcode-stdio-1.0 - main-is: test/doctests.hs - buildable: True - default-language: Haskell2010 - ghc-options: -Wall -threaded - if impl(ghc >= 8.2) - x-doctest-options: -fdiagnostics-color=never - include-dirs: include - x-doctest-source-dirs: test - x-doctest-modules: Servant.Utils.LinksSpec + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 diff --git a/src/Servant/API.hs b/src/Servant/API.hs --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -14,11 +14,17 @@ module Servant.API.Capture, -- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@ module Servant.API.Header, + -- | Matching the @Host@ header. + module Servant.API.Host, -- | Retrieving specific headers from the request module Servant.API.HttpVersion, -- | Retrieving the HTTP version of the request module Servant.API.QueryParam, -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ + module Servant.API.QueryString, + -- | Retrieving the complete query string of the 'URI': @'QueryString'@ + module Servant.API.Fragment, + -- | Documenting the fragment of the 'URI': @'Fragment'@ module Servant.API.ReqBody, -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ module Servant.API.RemoteHost, @@ -29,13 +35,23 @@ -- | Access the location for arbitrary data to be shared by applications and middleware module Servant.API.WithNamedContext, -- | Access context entries in combinators in servant-server + module Servant.API.WithResource, + -- | Access a managed resource scoped to a single request -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, + module Servant.API.UVerb, + -- * Sub-APIs defined as records of routes + module Servant.API.NamedRoutes, + module Servant.API.Generic, + -- * Streaming endpoints, distinguished by HTTP method module Servant.API.Stream, + -- * Server-sent events (SSE) + module Servant.API.ServerSentEvents, + -- * Authentication module Servant.API.BasicAuth, @@ -63,8 +79,8 @@ module Servant.API.Experimental.Auth, -- | General Authentication - -- * Utilities - module Servant.Utils.Links, + -- * Links + module Servant.Links, -- | Type-safe internal URIs -- * Re-exports @@ -92,49 +108,66 @@ (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) +import Servant.API.Fragment + (Fragment) +import Servant.API.Generic + (AsApi, GServantProduct, GenericMode ((:-)), GenericServant, + ToServant, ToServantApi, fromServant, genericApi, toServant) import Servant.API.Header (Header, Header') +import Servant.API.Host (Host) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) import Servant.API.Modifiers (Lenient, Optional, Required, Strict) +import Servant.API.NamedRoutes + (NamedRoutes) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) +import Servant.API.QueryString + (QueryString, DeepQuery) import Servant.API.Raw - (Raw) + (Raw, RawM) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody, ReqBody') import Servant.API.ResponseHeaders (AddHeader, BuildHeadersTo (buildHeadersTo), - GetHeaders (getHeaders), HList (..), Headers (..), - ResponseHeader (..), addHeader, getHeadersHList, getResponse, - noHeader) + GetHeaders (getHeaders), HList (..), HasResponseHeader, + Headers (..), ResponseHeader (..), addHeader, addHeader', + getHeadersHList, getResponse, lookupResponseHeader, noHeader, + noHeader') +import Servant.API.ServerSentEvents + (EventKind (..), ServerSentEvents, ServerSentEvents') import Servant.API.Stream - (BoundaryStrategy (..), BuildFromStream (..), - ByteStringParser (..), FramingRender (..), - FramingUnrender (..), NetstringFraming, NewlineFraming, - NoFraming, ResultStream (..), Stream, StreamGenerator (..), - StreamGet, StreamPost, ToStreamGenerator (..)) + (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, - Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative, - Post, PostAccepted, PostCreated, PostNoContent, - PostNonAuthoritative, PostResetContent, Put, PutAccepted, - PutNoContent, PutNonAuthoritative, + NoContentVerb, Patch, PatchAccepted, PatchNoContent, + PatchNonAuthoritative, Post, PostAccepted, PostCreated, + PostNoContent, PostNonAuthoritative, PostResetContent, Put, + PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext) -import Servant.Utils.Links +import Servant.API.WithResource + (WithResource) +import Servant.Links (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) diff --git a/src/Servant/API/Alternative.hs b/src/Servant/API/Alternative.hs --- a/src/Servant/API/Alternative.hs +++ b/src/Servant/API/Alternative.hs @@ -1,18 +1,22 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where -import Data.Semigroup - (Semigroup (..)) +#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) -import Prelude () -import Prelude.Compat -- | Union of two APIs, first takes precedence in case of overlap. -- @@ -23,7 +27,7 @@ -- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books -- :} data a :<|> b = a :<|> b - deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) + deriving stock (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) infixr 3 :<|> instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where @@ -31,7 +35,19 @@ instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty - (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') + +instance Bifoldable (:<|>) where + bifoldMap f g ~(a :<|> b) = f a `mappend` g b + +instance Bifunctor (:<|>) where + bimap f g ~(a :<|> b) = f a :<|> g b + +instance Biapplicative (:<|>) where + bipure = (:<|>) + (f :<|> g) <<*>> (a :<|> b) = f a :<|> g b + +instance Bitraversable (:<|>) where + bitraverse f g ~(a :<|> b) = liftA2 (:<|>) (f a) (g b) -- $setup -- >>> import Servant.API diff --git a/src/Servant/API/BasicAuth.hs b/src/Servant/API/BasicAuth.hs --- a/src/Servant/API/BasicAuth.hs +++ b/src/Servant/API/BasicAuth.hs @@ -1,12 +1,14 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} + {-# LANGUAGE PolyKinds #-} module Servant.API.BasicAuth where import Data.ByteString (ByteString) +import Data.Kind + (Type) import Data.Typeable (Typeable) import GHC.TypeLits @@ -24,7 +26,7 @@ -- In Basic Auth, username and password are base64-encoded and transmitted via -- the @Authorization@ header. Handshakes are not required, making it -- relatively efficient. -data BasicAuth (realm :: Symbol) (userData :: *) +data BasicAuth (realm :: Symbol) (userData :: Type) deriving (Typeable) -- | A simple datatype to hold data required to decorate a request diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs --- a/src/Servant/API/Capture.hs +++ b/src/Servant/API/Capture.hs @@ -4,6 +4,8 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Capture (Capture, Capture', CaptureAll) where +import Data.Kind + (Type) import Data.Typeable (Typeable) import GHC.TypeLits @@ -17,7 +19,7 @@ type Capture = Capture' '[] -- todo -- | 'Capture' which can be modified. For example with 'Description'. -data Capture' (mods :: [*]) (sym :: Symbol) (a :: *) +data Capture' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving (Typeable) -- | Capture all remaining values from the request path under a certain type @@ -27,7 +29,7 @@ -- -- >>> -- GET /src/* -- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile -data CaptureAll (sym :: Symbol) (a :: *) +data CaptureAll (sym :: Symbol) (a :: Type) deriving (Typeable) -- $setup diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -14,8 +14,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -#include "overlapping-compat.h" - -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from @@ -23,10 +21,10 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: -- --- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book +-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Put '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@ --- or @text/plain;charset-utf8@, and returns data in either one of those +-- or @text/plain;charset=utf8@, and returns data in either one of those -- formats (depending on the @Accept@ header). -- -- If you would like to support Content-Types beyond those provided here, @@ -51,6 +49,7 @@ , PlainText , FormUrlEncoded , OctetStream + , EventStream -- * Building your own Content-Type , Accept(..) @@ -69,28 +68,25 @@ , AllMimeUnrender(..) , eitherDecodeLenient , canHandleAcceptH + , EventStreamChunk(..) ) where import Control.Arrow (left) -import Control.Monad.Compat +import Control.DeepSeq + (NFData) import Data.Aeson - (FromJSON (..), ToJSON (..), encode) -import Data.Aeson.Parser - (value) -import Data.Aeson.Types - (parseEither) -import Data.Attoparsec.ByteString.Char8 - (endOfInput, parseOnly, skipSpace, ()) + (FromJSON (..), ToJSON (..), encode, eitherDecode) +import Data.Bifunctor + (bimap) import qualified Data.ByteString as BS import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) -import qualified Data.ByteString.Lazy.Char8 as BC +import Data.Kind + (Type) import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) -import Data.String.Conversions - (cs) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL @@ -98,21 +94,17 @@ import Data.Typeable import GHC.Generics (Generic) +import qualified GHC.TypeLits as TL import qualified Network.HTTP.Media as M -import Prelude () -import Prelude.Compat import Web.FormUrlEncoded (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) -#if MIN_VERSION_base(4,9,0) -import qualified GHC.TypeLits as TL -#endif - -- * 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 @@ -156,6 +148,10 @@ instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" +-- | @text/event-stream@ +instance Accept EventStream where + contentType _ = "text" M.// "event-stream" + newtype AcceptHeader = AcceptHeader BS.ByteString deriving (Eq, Show, Read, Typeable, Generic) @@ -179,24 +175,22 @@ class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -class (AllMime list) => AllCTRender (list :: [*]) a where +class (AllMime list) => AllCTRender (list :: [Type]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} (Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs -#if MIN_VERSION_base(4,9,0) instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTRender '[] () where handleAcceptH _ _ _ = error "unreachable" -#endif -------------------------------------------------------------------------- -- * Unrender @@ -235,7 +229,7 @@ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} -class AllCTUnrender (list :: [*]) a where +class AllCTUnrender (list :: [Type]) a where canHandleCTypeH :: Proxy list -> ByteString -- Content-Type header @@ -249,12 +243,12 @@ instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where canHandleCTypeH p ctypeH = - M.mapContentMedia (allMimeUnrender p) (cs ctypeH) + M.mapContentMedia (allMimeUnrender p) (toStrict ctypeH) -------------------------------------------------------------------------- -- * Utils (Internal) -class AllMime (list :: [*]) where +class AllMime (list :: [Type]) where allMime :: Proxy list -> [M.MediaType] instance AllMime '[] where @@ -272,18 +266,18 @@ -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeRender -------------------------------------------------------------------------- -class (AllMime list) => AllMimeRender (list :: [*]) a where +class (AllMime list) => AllMimeRender (list :: [Type]) a where allMimeRender :: Proxy list -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs -instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where +instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp where bs = mimeRender pctyp a pctyp = Proxy :: Proxy ctyp -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where @@ -299,20 +293,20 @@ -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and -- then this would be taken care of. However there is no more specific instance -- between that and 'MimeRender JSON a', so we do this instead -instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where - allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp +instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where + allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp where pctyp = Proxy :: Proxy ctyp -instance OVERLAPPING_ +instance {-# OVERLAPPING #-} ( AllMime (ctyp ': ctyp' ': ctyps) ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where - allMimeRender p _ = zip (allMime p) (repeat "") + allMimeRender p _ = map (, "") (allMime p) -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender -------------------------------------------------------------------------- -class (AllMime list) => AllMimeUnrender (list :: [*]) a where +class (AllMime list) => AllMimeUnrender (list :: [Type]) a where allMimeUnrender :: Proxy list -> [(M.MediaType, ByteString -> Either String a)] @@ -334,14 +328,14 @@ -- * MimeRender Instances -- | `encode` -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @urlEncodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} ToForm a => MimeRender FormUrlEncoded a where mimeRender _ = urlEncodeAsForm @@ -355,7 +349,7 @@ -- | @BC.pack@ instance MimeRender PlainText String where - mimeRender _ = BC.pack + mimeRender _ = TextL.encodeUtf8 . TextL.pack -- | @id@ instance MimeRender OctetStream ByteString where @@ -369,32 +363,21 @@ data NoContent = NoContent deriving (Show, Eq, Read, Generic) +instance NFData NoContent + -------------------------------------------------------------------------- -- * MimeUnrender Instances --- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just --- objects and arrays. --- --- Will handle trailing whitespace, but not trailing junk. ie. --- --- >>> eitherDecodeLenient "1 " :: Either String Int --- Right 1 +-- | Deprecated: since aeson version 0.9 `eitherDecode` has lenient behavior. -- --- >>> eitherDecodeLenient "1 junk" :: Either String Int --- Left "trailing junk after valid JSON: endOfInput" eitherDecodeLenient :: FromJSON a => ByteString -> Either String a -eitherDecodeLenient input = - parseOnly parser (cs input) >>= parseEither parseJSON - where - parser = skipSpace - *> Data.Aeson.Parser.value - <* skipSpace - <* (endOfInput "trailing junk after valid JSON") +eitherDecodeLenient = eitherDecode +{-# DEPRECATED eitherDecodeLenient "use eitherDecode instead" #-} -- | `eitherDecode` instance FromJSON a => MimeUnrender JSON a where - mimeUnrender _ = eitherDecodeLenient + mimeUnrender _ = eitherDecode -- | @urlDecodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only @@ -412,17 +395,22 @@ -- | @Right . BC.unpack@ instance MimeUnrender PlainText String where - mimeUnrender _ = Right . BC.unpack + mimeUnrender _ = bimap show TextL.unpack . TextL.decodeUtf8' -- | @Right . id@ instance MimeUnrender OctetStream ByteString where - mimeUnrender _ = Right . id + mimeUnrender _ = Right -- | @Right . toStrict@ instance MimeUnrender OctetStream BS.ByteString where mimeUnrender _ = Right . toStrict +-- | Chunk of an event stream +newtype EventStreamChunk = EventStreamChunk + { unEventStreamChunk :: ByteString } +instance MimeUnrender EventStream EventStreamChunk where + mimeUnrender _ = Right . EventStreamChunk -- $setup -- >>> :set -XFlexibleInstances diff --git a/src/Servant/API/Description.hs b/src/Servant/API/Description.hs --- a/src/Servant/API/Description.hs +++ b/src/Servant/API/Description.hs @@ -16,6 +16,8 @@ reflectDescription, ) where +import Data.Kind + (Type) import Data.Proxy (Proxy (..)) import Data.Typeable @@ -39,14 +41,14 @@ --type MyApi = Description -- "This comment is visible in multiple Servant interpretations \ -- \and can be really long if necessary. \ --- \Haskell multiline support is not perfect \ +-- \Haskell multiline String support is not perfect \ -- \but it's still very readable." -- :> Get '[JSON] Book -- :} data Description (sym :: Symbol) deriving (Typeable) --- | Fold modifier list to decide whether argument should be parsed strictly or leniently. +-- | Fold list of modifiers to extract description as a type-level String. -- -- >>> :kind! FoldDescription '[] -- FoldDescription '[] :: Symbol @@ -59,7 +61,7 @@ type FoldDescription mods = FoldDescription' "" mods -- | Implementation of 'FoldDescription'. -type family FoldDescription' (acc :: Symbol) (mods :: [*]) :: Symbol where +type family FoldDescription' (acc :: Symbol) (mods :: [Type]) :: Symbol where FoldDescription' acc '[] = acc FoldDescription' acc (Description desc ': mods) = FoldDescription' desc mods FoldDescription' acc (mod ': mods) = FoldDescription' acc mods diff --git a/src/Servant/API/Empty.hs b/src/Servant/API/Empty.hs --- a/src/Servant/API/Empty.hs +++ b/src/Servant/API/Empty.hs @@ -2,10 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Empty(EmptyAPI(..)) where -import Data.Typeable - (Typeable) -import Prelude () -import Prelude.Compat +import Data.Typeable (Typeable) -- | An empty API: one which serves nothing. Morally speaking, this should be -- the unit of ':<|>'. Implementors of interpretations of API types should diff --git a/src/Servant/API/Experimental/Auth.hs b/src/Servant/API/Experimental/Auth.hs --- a/src/Servant/API/Experimental/Auth.hs +++ b/src/Servant/API/Experimental/Auth.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} + {-# LANGUAGE PolyKinds #-} module Servant.API.Experimental.Auth where diff --git a/src/Servant/API/Fragment.hs b/src/Servant/API/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Fragment.hs @@ -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 } diff --git a/src/Servant/API/Generic.hs b/src/Servant/API/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Generic.hs @@ -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 diff --git a/src/Servant/API/Header.hs b/src/Servant/API/Header.hs --- a/src/Servant/API/Header.hs +++ b/src/Servant/API/Header.hs @@ -6,6 +6,8 @@ Header, Header', ) where +import Data.Kind + (Type) import Data.Typeable (Typeable) import GHC.TypeLits @@ -23,7 +25,7 @@ -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer type Header = Header' '[Optional, Strict] -data Header' (mods :: [*]) (sym :: Symbol) a +data Header' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving Typeable -- $setup diff --git a/src/Servant/API/Host.hs b/src/Servant/API/Host.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Host.hs @@ -0,0 +1,13 @@ +module Servant.API.Host (Host) where + +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) + +-- | Match against the given host. +-- +-- This allows you to define APIs over multiple domains. For example: +-- +-- > type API = Host "api1.example" :> API1 +-- > :<|> Host "api2.example" :> API2 +-- +data Host (sym :: Symbol) deriving Typeable diff --git a/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/src/Servant/API/Internal/Test/ComprehensiveAPI.hs deleted file mode 100644 --- a/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - --- | This is a module containing an API with all `Servant.API` combinators. It --- is used for testing only (in particular, checking that instances exist for --- the core servant classes for each combinator), and should not be imported. -module Servant.API.Internal.Test.ComprehensiveAPI where - -import Data.Proxy -import Servant.API - -type GET = Get '[JSON] NoContent - -type ComprehensiveAPI = - ComprehensiveAPIWithoutRaw :<|> - Raw - -comprehensiveAPI :: Proxy ComprehensiveAPI -comprehensiveAPI = Proxy - -type ComprehensiveAPIWithoutRaw = - GET :<|> - Get '[JSON] Int :<|> - Capture' '[Description "example description"] "foo" Int :> GET :<|> - Header "foo" Int :> GET :<|> - Header' '[Required, Lenient] "bar" Int :> GET :<|> - HttpVersion :> GET :<|> - IsSecure :> GET :<|> - QueryParam "foo" Int :> GET :<|> - QueryParam' '[Required, Lenient] "bar" Int :> GET :<|> - QueryParams "foo" Int :> GET :<|> - QueryFlag "foo" :> GET :<|> - RemoteHost :> GET :<|> - ReqBody '[JSON] Int :> GET :<|> - ReqBody' '[Lenient] '[JSON] Int :> GET :<|> - Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> - "foo" :> GET :<|> - Vault :> GET :<|> - Verb 'POST 204 '[JSON] NoContent :<|> - Verb 'POST 204 '[JSON] Int :<|> - WithNamedContext "foo" '[] GET :<|> - CaptureAll "foo" Int :> GET :<|> - Summary "foo" :> GET :<|> - Description "foo" :> GET :<|> - EmptyAPI - -comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw -comprehensiveAPIWithoutRaw = Proxy diff --git a/src/Servant/API/Modifiers.hs b/src/Servant/API/Modifiers.hs --- a/src/Servant/API/Modifiers.hs +++ b/src/Servant/API/Modifiers.hs @@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} + {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Servant.API.Modifiers ( -- * Required / optional argument Required, Optional, @@ -19,6 +20,8 @@ unfoldRequestArgument, ) where +import Data.Kind + (Type) import Data.Proxy (Proxy (..)) import Data.Singletons.Bool @@ -51,7 +54,7 @@ type FoldRequired mods = FoldRequired' 'False mods -- | Implementation of 'FoldRequired'. -type family FoldRequired' (acc :: Bool) (mods :: [*]) :: Bool where +type family FoldRequired' (acc :: Bool) (mods :: [Type]) :: Bool where FoldRequired' acc '[] = acc FoldRequired' acc (Required ': mods) = FoldRequired' 'True mods FoldRequired' acc (Optional ': mods) = FoldRequired' 'False mods @@ -72,7 +75,7 @@ type FoldLenient mods = FoldLenient' 'False mods -- | Implementation of 'FoldLenient'. -type family FoldLenient' (acc :: Bool) (mods :: [*]) :: Bool where +type family FoldLenient' (acc :: Bool) (mods :: [Type]) :: Bool where FoldLenient' acc '[] = acc FoldLenient' acc (Lenient ': mods) = FoldLenient' 'True mods FoldLenient' acc (Strict ': mods) = FoldLenient' 'False mods @@ -130,8 +133,6 @@ If (FoldRequired mods) (If (FoldLenient mods) (Either Text a) a) (Maybe (If (FoldLenient mods) (Either Text a) a)) - - -- | Unfold a value into a 'RequestArgument'. unfoldRequestArgument diff --git a/src/Servant/API/MultiVerb.hs b/src/Servant/API/MultiVerb.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/MultiVerb.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE EmptyCase #-} + +-- | MultiVerb is a part of the type-level eDSL that allows you to express complex routes +-- while retaining a high level of precision with good ergonomics. + +module Servant.API.MultiVerb + ( -- ** MultiVerb types + MultiVerb, + MultiVerb1, + -- ** Response types + Respond, + RespondAs, + RespondEmpty, + RespondStreaming, + -- ** Headers + WithHeaders, + DescHeader, + OptHeader, + AsHeaders (..), + ServantHeaders(..), + ServantHeader(..), + -- ** Unions of responses + AsUnion (..), + eitherToUnion, + eitherFromUnion, + maybeToUnion, + maybeFromUnion, + -- ** Internal machinery + AsConstructor (..), + GenericAsConstructor (..), + GenericAsUnion (..), + ResponseType, + ResponseTypes, + UnrenderResult(..), + ) where + + +import Control.Applicative (Alternative(..), empty) +import Control.Monad (ap, MonadPlus(..)) +import Data.ByteString (ByteString) +import Data.Kind +import Data.Proxy +import Data.SOP +import Data.Sequence (Seq(..)) +import GHC.TypeLits +import Generics.SOP as GSOP +import Network.HTTP.Types as HTTP +import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) +import qualified Data.CaseInsensitive as CI +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Servant.API.TypeLevel.List +import Servant.API.Stream (SourceIO) +import Servant.API.UVerb.Union (Union) +import Servant.API.Header (Header') + +-- | A type to describe a 'MultiVerb' response. +-- +-- Includes status code, description, and return type. The content type of the +-- response is determined dynamically using the accept header and the list of +-- supported content types specified in the containing 'MultiVerb' type. +data Respond (s :: Nat) (description :: Symbol) (a :: Type) + +-- | A type to describe a 'MultiVerb' response with a fixed content type. +-- +-- Similar to 'Respond', but hardcodes the content type to be used for +-- generating the response. This content type is distinct from the one +-- given to 'MultiVerb', as it dictactes the response's content type, not the +-- content type request that is to be accepted. +data RespondAs responseContentType (s :: Nat) (description :: Symbol) (a :: Type) + +-- | A type to describe a 'MultiVerb' response with an empty body. +-- +-- Includes status code and description. +type RespondEmpty s description = RespondAs '() s description () + +-- | A type to describe a streaming 'MultiVerb' response. +-- +-- Includes status code, description, framing strategy and content type. Note +-- that the handler return type is hardcoded to be 'SourceIO ByteString'. +data RespondStreaming (s :: Nat) (description :: Symbol) (framing :: Type) (ct :: Type) + +-- | The result of parsing a response as a union alternative of type 'a'. +-- +-- 'StatusMismatch' indicates that the response does not refer to the given +-- alternative, because the status code does not match the one produced by that +-- alternative. +-- +-- 'UnrenderError' and 'UnrenderSuccess' represent respectively a failing and +-- successful parse of the response body as a value of type 'a'. +-- +-- The 'UnrenderResult' type constructor has monad and alternative instances +-- corresponding to those of 'Either (Maybe (Last String)) a'. +data UnrenderResult a = StatusMismatch | UnrenderError String | UnrenderSuccess a + deriving (Eq, Show, Functor) + +instance Applicative UnrenderResult where + pure = UnrenderSuccess + (<*>) = ap + +instance Monad UnrenderResult where + return = pure + StatusMismatch >>= _ = StatusMismatch + UnrenderError e >>= _ = UnrenderError e + UnrenderSuccess x >>= f = f x + +instance Alternative UnrenderResult where + empty = mzero + (<|>) = mplus + +instance MonadPlus UnrenderResult where + mzero = StatusMismatch + mplus StatusMismatch m = m + mplus (UnrenderError e) StatusMismatch = UnrenderError e + mplus (UnrenderError _) m = m + mplus m@(UnrenderSuccess _) _ = m + +type family ResponseType a :: Type + +type instance ResponseType (Respond s description a) = a + +type instance ResponseType (RespondAs responseContentType s description a) = a + +type instance ResponseType (RespondStreaming s description framing ct) = SourceIO ByteString + + +-- | This type adds response headers to a 'MultiVerb' response. +data WithHeaders (headers :: [Type]) (returnType :: Type) (response :: Type) + +-- | This is used to convert a response containing headers to a custom type +-- including the information in the headers. +-- +-- If you need to send a combination of headers and response that is not provided by Servant, +-- you can cwrite your own instance. Take example on the ones provided. +class AsHeaders headers response returnType where + fromHeaders :: (NP I headers, response) -> returnType + toHeaders :: returnType -> (NP I headers, response) + +-- | Single-header empty response +instance AsHeaders '[a] () a where + toHeaders a = (I a :* Nil, ()) + fromHeaders = unI . hd . fst + +-- | Single-header non-empty response, return value is a tuple of the response and the header +instance AsHeaders '[h] a (a, h) where + toHeaders (t, cc) = (I cc :* Nil, t) + fromHeaders (I cc :* Nil, t) = (t, cc) + +-- | Two headers and an empty response, return value is a tuple of the response and the header +instance AsHeaders '[a, b] () (a, b) where + toHeaders (h1, h2) = (I h1 :* I h2 :* Nil, ()) + fromHeaders (I h1 :* I h2 :* Nil, ()) = (h1, h2) + +data DescHeader (name :: Symbol) (description :: Symbol) (a :: Type) + +-- | A wrapper to turn a response header into an optional one. +data OptHeader h + +class ServantHeaders headers xs | headers -> xs where + constructHeaders :: NP I xs -> [HTTP.Header] + extractHeaders :: Seq HTTP.Header -> Maybe (NP I xs) + +instance ServantHeaders '[] '[] where + constructHeaders Nil = [] + extractHeaders _ = Just Nil + +headerName :: forall name. (KnownSymbol name) => HTTP.HeaderName +headerName = + CI.mk + . Text.encodeUtf8 + . Text.pack + $ symbolVal (Proxy @name) + +instance + ( KnownSymbol name, + ServantHeader h name x, + FromHttpApiData x, + ServantHeaders headers xs + ) => + ServantHeaders (h ': headers) (x ': xs) + where + constructHeaders (I x :* xs) = + constructHeader @h x + <> constructHeaders @headers xs + + -- NOTE: should we concatenate all the matching headers instead of just taking the first one? + extractHeaders headers = do + let name' = headerName @name + (headers0, headers1) = Seq.partition (\(h, _) -> h == name') headers + x <- case headers0 of + Seq.Empty -> empty + ((_, h) :<| _) -> either (const empty) pure (parseHeader h) + xs <- extractHeaders @headers headers1 + pure (I x :* xs) + +class ServantHeader h (name :: Symbol) x | h -> name x where + constructHeader :: x -> [HTTP.Header] + +instance + (KnownSymbol name, ToHttpApiData x) => + ServantHeader (Header' mods name x) name x + where + constructHeader x = [(headerName @name, toHeader x)] + +instance + (KnownSymbol name, ToHttpApiData x) => + ServantHeader (DescHeader name description x) name x + where + constructHeader x = [(headerName @name, toHeader x)] + +instance (ServantHeader h name x) => ServantHeader (OptHeader h) name (Maybe x) where + constructHeader = foldMap (constructHeader @h) + +type instance ResponseType (WithHeaders headers returnType response) = returnType + + +type family ResponseTypes (as :: [Type]) where + ResponseTypes '[] = '[] + ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as + + +-- | 'MultiVerb' produces an endpoint which can return +-- multiple values with various content types and status codes. It is similar to +-- 'Servant.API.UVerb.UVerb' and behaves similarly, but it has some important differences: +-- +-- * Descriptions and statuses can be attached to individual responses without +-- using wrapper types and without affecting the handler return type. +-- * The return type of the handler can be decoupled from the types of the +-- individual responses. One can use a 'Union' type just like for 'Servant.API.UVerb.UVerb', +-- but 'MultiVerb' also supports using an arbitrary type with an 'AsUnion' +-- instance. Each response is responsible for their content type. +-- * Headers can be attached to individual responses, also without affecting +-- the handler return type. +-- +-- ==== __Example__ +-- Let us create an endpoint that captures an 'Int' and has the following logic: +-- +-- * If the number is negative, we return status code 400 and an empty body; +-- * If the number is even, we return a 'Bool' in the response body; +-- * If the number is odd, we return another 'Int' in the response body. +-- +-- > import qualified Generics.SOP as GSOP +-- +-- > -- All possible HTTP responses +-- > type Responses = +-- > '[ type RespondEmpty 400 "Negative" +-- > , type Respond 200 "Even number" Bool +-- > , type Respond 200 "Odd number" Int +-- > ] +-- > +-- > -- All possible return types +-- > data Result +-- > = NegativeNumber +-- > | Odd Int +-- > | Even Bool +-- > deriving stock (Generic) +-- > deriving (AsUnion Responses) +-- > via GenericAsUnion Responses Result +-- > +-- > instance GSOP.Generic Result +-- +-- These deriving statements above tie together the responses and the return values, and the order in which they are defined matters. For instance, if @Even@ and @Odd@ had switched places in the definition of @Result@, this would provoke an error: +-- +-- +-- > • No instance for ‘AsConstructor +-- > ((:) @Type Int ('[] @Type)) (Respond 200 "Even number" Bool)’ +-- > arising from the 'deriving' clause of a data type declaration +-- +-- If you would prefer to write an intance of 'AsUnion' by yourself, read more in the typeclass' documentation. +-- +-- Finally, let us write our endpoint description: +-- +-- > type MultipleChoicesInt = +-- > Capture "int" Int +-- > :> MultiVerb +-- > 'GET +-- > '[JSON] +-- > Responses +-- > Result +data MultiVerb (method :: StdMethod) requestMimeTypes (as :: [Type]) (responses :: Type) + +-- | A 'MultiVerb' endpoint with a single response. Ideal to ensure that there can only be one response. +type MultiVerb1 method requestMimeTypes a = MultiVerb method requestMimeTypes '[a] (ResponseType a) + +-- | This class is used to convert a handler return type to a union type +-- including all possible responses of a 'MultiVerb' endpoint. +-- +-- Any glue code necessary to convert application types to and from the +-- canonical 'Union' type corresponding to a 'MultiVerb' endpoint should be +-- packaged into an 'AsUnion' instance. +-- +-- ==== __Example__ +-- Let us take the example endpoint from the 'MultiVerb' documentation. +-- There, we derived the 'AsUnion' instance with the help of Generics. +-- The manual way of implementing the instance is: +-- +-- > instance AsUnion Responses Result where +-- > toUnion NegativeNumber = Z (I ()) +-- > toUnion (Even b) = S (Z (I b)) +-- > toUnion (Odd i) = S (S (Z (I i))) +-- > +-- > fromUnion (Z (I ())) = NegativeNumber +-- > fromUnion (S (Z (I b))) = Even b +-- > fromUnion (S (S (Z (I i)))) = Odd i +-- > fromUnion (S (S (S x))) = case x of {} +-- The last 'fromUnion' equation is here to please the pattern checker. +class AsUnion (as :: [Type]) (r :: Type) where + toUnion :: r -> Union (ResponseTypes as) + fromUnion :: Union (ResponseTypes as) -> r + +-- | Unions can be used directly as handler return types using this trivial +-- instance. +instance (rs ~ ResponseTypes as) => AsUnion as (Union rs) where + toUnion = id + fromUnion = id + +-- | A handler with a single response. +instance (ResponseType r ~ a) => AsUnion '[r] a where + toUnion = Z . I + fromUnion = unI . unZ + +_foo :: Union '[Int] +_foo = toUnion @'[Respond 200 "test" Int] @Int 3 + +class InjectAfter as bs where + injectAfter :: Union bs -> Union (as .++ bs) + +instance InjectAfter '[] bs where + injectAfter = id + +instance (InjectAfter as bs) => InjectAfter (a ': as) bs where + injectAfter = S . injectAfter @as @bs + +class InjectBefore as bs where + injectBefore :: Union as -> Union (as .++ bs) + +instance InjectBefore '[] bs where + injectBefore x = case x of {} + +instance (InjectBefore as bs) => InjectBefore (a ': as) bs where + injectBefore (Z x) = Z x + injectBefore (S x) = S (injectBefore @as @bs x) + +eitherToUnion :: + forall as bs a b. + (InjectAfter as bs, InjectBefore as bs) => + (a -> Union as) -> + (b -> Union bs) -> + (Either a b -> Union (as .++ bs)) +eitherToUnion f _ (Left a) = injectBefore @as @bs (f a) +eitherToUnion _ g (Right b) = injectAfter @as @bs (g b) + +class EitherFromUnion as bs where + eitherFromUnion :: + (Union as -> a) -> + (Union bs -> b) -> + (Union (as .++ bs) -> Either a b) + +instance EitherFromUnion '[] bs where + eitherFromUnion _ g = Right . g + +instance (EitherFromUnion as bs) => EitherFromUnion (a ': as) bs where + eitherFromUnion f _ (Z x) = Left (f (Z x)) + eitherFromUnion f g (S x) = eitherFromUnion @as @bs (f . S) g x + +maybeToUnion :: + forall as a. + (InjectAfter as '[()], InjectBefore as '[()]) => + (a -> Union as) -> + (Maybe a -> Union (as .++ '[()])) +maybeToUnion f (Just a) = injectBefore @as @'[()] (f a) +maybeToUnion _ Nothing = injectAfter @as @'[()] (Z (I ())) + +maybeFromUnion :: + forall as a. + (EitherFromUnion as '[()]) => + (Union as -> a) -> + (Union (as .++ '[()]) -> Maybe a) +maybeFromUnion f = + leftToMaybe . eitherFromUnion @as @'[()] f (const (Z (I ()))) + where + leftToMaybe = either Just (const Nothing) + +-- | This class can be instantiated to get automatic derivation of 'AsUnion' +-- instances via 'GenericAsUnion'. The idea is that one has to make sure that for +-- each response @r@ in a 'MultiVerb' endpoint, there is an instance of +-- @AsConstructor xs r@ for some @xs@, and that the list @xss@ of all the +-- corresponding @xs@ is equal to 'GSOP.Code' of the handler type. Then one can +-- write: +-- @ +-- type Responses = ... +-- data Result = ... +-- deriving stock (Generic) +-- deriving (AsUnion Responses) via (GenericAsUnion Responses Result) +-- +-- instance GSOP.Generic Result +-- @ +-- and get an 'AsUnion' instance for free. +-- +-- There are a few predefined instances for constructors taking a single type +-- corresponding to a simple response, and for empty responses, but in more +-- general cases one either has to define an 'AsConstructor' instance by hand, +-- or derive it via 'GenericAsConstructor'. +class AsConstructor xs r where + toConstructor :: ResponseType r -> NP I xs + fromConstructor :: NP I xs -> ResponseType r + +class AsConstructors xss rs where + toSOP :: Union (ResponseTypes rs) -> SOP I xss + fromSOP :: SOP I xss -> Union (ResponseTypes rs) + +instance AsConstructors '[] '[] where + toSOP x = case x of {} + fromSOP x = case x of {} + +instance AsConstructor '[a] (Respond code description a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + +instance AsConstructor '[a] (RespondAs (responseContentTypes :: Type) code description a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + +instance AsConstructor '[] (RespondEmpty code description) where + toConstructor _ = Nil + fromConstructor _ = () + +instance AsConstructor '[a] (WithHeaders headers a response) where + toConstructor a = I a :* Nil + fromConstructor (I a :* Nil) = a + +newtype GenericAsConstructor r = GenericAsConstructor r + +type instance ResponseType (GenericAsConstructor r) = ResponseType r + +instance + (GSOP.Code (ResponseType r) ~ '[xs], GSOP.Generic (ResponseType r)) => + AsConstructor xs (GenericAsConstructor r) + where + toConstructor = unZ . unSOP . GSOP.from + fromConstructor = GSOP.to . SOP . Z + +instance + (AsConstructor xs r, AsConstructors xss rs) => + AsConstructors (xs ': xss) (r ': rs) + where + toSOP (Z (I x)) = SOP . Z $ toConstructor @xs @r x + toSOP (S x) = SOP . S . unSOP $ toSOP @xss @rs x + + fromSOP (SOP (Z x)) = Z (I (fromConstructor @xs @r x)) + fromSOP (SOP (S x)) = S (fromSOP @xss @rs (SOP x)) + +-- | This type is meant to be used with @deriving via@ in order to automatically +-- generate an 'AsUnion' instance using 'Generics.SOP'. +-- +-- See 'AsConstructor' for more information and examples. +newtype GenericAsUnion rs a = GenericAsUnion a + +instance + (GSOP.Code a ~ xss, GSOP.Generic a, AsConstructors xss rs) => + AsUnion rs (GenericAsUnion rs a) + where + toUnion (GenericAsUnion x) = fromSOP @xss @rs (GSOP.from x) + fromUnion = GenericAsUnion . GSOP.to . toSOP @xss @rs + +-- | A handler for a pair of empty responses can be implemented simply by +-- returning a boolean value. The convention is that the "failure" case, normally +-- represented by 'False', corresponds to the /first/ response. +instance + AsUnion + '[ RespondEmpty s1 desc1, + RespondEmpty s2 desc2 + ] + Bool + where + toUnion False = Z (I ()) + toUnion True = S (Z (I ())) + + fromUnion (Z (I ())) = False + fromUnion (S (Z (I ()))) = True + fromUnion (S (S x)) = case x of {} + +-- | A handler for a pair of responses where the first is empty can be +-- implemented simply by returning a 'Maybe' value. The convention is that the +-- "failure" case, normally represented by 'Nothing', corresponds to the /first/ +-- response. +instance + {-# OVERLAPPABLE #-} + (ResponseType r1 ~ (), ResponseType r2 ~ a) => + AsUnion '[r1, r2] (Maybe a) + where + toUnion Nothing = Z (I ()) + toUnion (Just x) = S (Z (I x)) + + fromUnion (Z (I ())) = Nothing + fromUnion (S (Z (I x))) = Just x + fromUnion (S (S x)) = case x of {} diff --git a/src/Servant/API/NamedRoutes.hs b/src/Servant/API/NamedRoutes.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/NamedRoutes.hs @@ -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) diff --git a/src/Servant/API/QueryParam.hs b/src/Servant/API/QueryParam.hs --- a/src/Servant/API/QueryParam.hs +++ b/src/Servant/API/QueryParam.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} + {-# OPTIONS_HADDOCK not-home #-} module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where +import Data.Kind + (Type) import Data.Typeable (Typeable) import GHC.TypeLits @@ -21,7 +23,7 @@ type QueryParam = QueryParam' '[Optional, Strict] -- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise. -data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *) +data QueryParam' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving Typeable -- | Lookup the values associated to the @sym@ query string parameter @@ -35,7 +37,7 @@ -- -- >>> -- /books?authors[]=&authors[]=&... -- >>> type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] -data QueryParams (sym :: Symbol) (a :: *) +data QueryParams (sym :: Symbol) (a :: Type) deriving Typeable -- | Lookup a potentially value-less query string parameter diff --git a/src/Servant/API/QueryString.hs b/src/Servant/API/QueryString.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/QueryString.hs @@ -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=&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]=&filter[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) diff --git a/src/Servant/API/Range.hs b/src/Servant/API/Range.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Range.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Servant.API.Range (Range (unRange), unsafeRange, mkRange) where + +import Data.Aeson +import Data.Aeson.Types (modifyFailure) +import Data.Bifunctor (first) +import Data.Ix +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import GHC.Generics (Generic) +import GHC.TypeLits +import Servant.API + +-- | A newtype wrapper around 'Natural' that ensures the value is within a given range. +-- +-- Example: +-- +-- >>> :{ +-- let validRange = mkRange 5 :: Maybe (Range 1 10) +-- in case validRange of +-- Just r -> "Valid range: " ++ show (unRange r) +-- Nothing -> "Invalid range" +-- :} +-- "Valid range: 5" +-- +-- >>> :{ +-- let invalidRange = mkRange 15 :: Maybe (Range 1 10) +-- in case invalidRange of +-- Just r -> "Valid range: " ++ show (unRange r) +-- Nothing -> "Invalid range" +-- :} +-- "Invalid range" +-- +-- >>> decode "5" :: Maybe (Range 1 10) +-- Just (MkRange {unRange = 5}) +-- +-- >>> decode "15" :: Maybe (Range 1 10) +-- Nothing +newtype Range (min :: Nat) (max :: Nat) = MkRange {unRange :: Natural} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (Ix, ToJSON, ToHttpApiData) + +unsafeRange :: Natural -> Range min max +unsafeRange = MkRange + +instance (KnownNat min, KnownNat max) => Bounded (Range min max) where + minBound = MkRange . fromInteger $ natVal (Proxy @min) + maxBound = MkRange . fromInteger $ natVal (Proxy @max) + +parseErrorMsg :: forall min max. (KnownNat min, KnownNat max) => Proxy (Range min max) -> String +parseErrorMsg _ = + "Expecting a natural number between " <> show (natVal (Proxy @min)) <> " and " <> show (natVal (Proxy @max)) <> "." + +mkRange :: forall min max. (KnownNat min, KnownNat max) => Natural -> Maybe (Range min max) +mkRange n + | inRange (minBound :: Range min max, maxBound :: Range min max) (MkRange n) = Just (MkRange n) + | otherwise = Nothing + +instance (KnownNat min, KnownNat max) => FromJSON (Range min max) where + parseJSON v = do + n <- modifyFailure (const $ parseErrorMsg @min @max Proxy) $ parseJSON v + maybe (fail $ parseErrorMsg @min @max Proxy) pure $ mkRange n + +instance (KnownNat min, KnownNat max) => FromHttpApiData (Range min max) where + parseQueryParam v = do + n <- first (const . T.pack $ parseErrorMsg @min @max Proxy) $ parseQueryParam v + maybe (Left . T.pack $ parseErrorMsg @min @max Proxy) Right $ mkRange n diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -11,6 +11,10 @@ -- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's, --- this can also be used with to serve --- static files stored in a particular directory on your filesystem +-- this can also be used with functions from +-- +-- 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 diff --git a/src/Servant/API/ReqBody.hs b/src/Servant/API/ReqBody.hs --- a/src/Servant/API/ReqBody.hs +++ b/src/Servant/API/ReqBody.hs @@ -6,6 +6,8 @@ ReqBody, ReqBody', ) where +import Data.Kind + (Type) import Data.Typeable (Typeable) import Servant.API.Modifiers @@ -21,7 +23,7 @@ -- | -- -- /Note:/ 'ReqBody'' is always 'Required'. -data ReqBody' (mods :: [*]) (contentTypes :: [*]) (a :: *) +data ReqBody' (mods :: [Type]) (contentTypes :: [Type]) (a :: Type) deriving (Typeable) -- $setup diff --git a/src/Servant/API/ResponseHeaders.hs b/src/Servant/API/ResponseHeaders.hs --- a/src/Servant/API/ResponseHeaders.hs +++ b/src/Servant/API/ResponseHeaders.hs @@ -1,21 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int @@ -27,16 +12,26 @@ , 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, init, pack, unlines) + (ByteString, pack) import qualified Data.CaseInsensitive as CI +import Data.Kind + (Type) +import qualified Data.List as L import Data.Proxy import Data.Typeable (Typeable) @@ -46,10 +41,13 @@ import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) -import Prelude () -import Prelude.Compat import Servant.API.Header - (Header) + (Header') +import Servant.API.Modifiers + (Optional, Strict) +import Servant.API.UVerb.Union +import qualified Data.SOP.BasicFunctors as SOP +import qualified Data.SOP.NS as SOP -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addOptionalHeader'. @@ -59,43 +57,56 @@ -- ^ HList of headers. } deriving (Functor) +instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where + rnf (Headers x hdrs) = rnf x `seq` rnf hdrs + data ResponseHeader (sym :: Symbol) a = Header a | MissingHeader | UndecodableHeader ByteString deriving (Typeable, Eq, Show, Functor) +instance NFData a => NFData (ResponseHeader sym a) where + rnf MissingHeader = () + rnf (UndecodableHeader bs) = rnf bs + rnf (Header x) = rnf x + data HList a where HNil :: HList '[] - HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs) + HCons :: ResponseHeader h x -> HList xs -> HList (Header' mods h x ': xs) -type family HeaderValMap (f :: * -> *) (xs :: [*]) where +class NFDataHList xs where rnfHList :: HList xs -> () +instance NFDataHList '[] where rnfHList HNil = () +instance (y ~ Header' mods h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where + rnfHList (HCons h xs) = rnf h `seq` rnfHList xs + +instance NFDataHList xs => NFData (HList xs) where + rnf = rnfHList + +type family HeaderValMap (f :: Type -> Type) (xs :: [Type]) where HeaderValMap f '[] = '[] - HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs + HeaderValMap f (Header' mods h x ': xs) = Header' mods h (f x) ': HeaderValMap f xs class BuildHeadersTo hs where buildHeadersTo :: [HTTP.Header] -> HList hs - -- ^ Note: if there are multiple occurences of a header in the argument, - -- the values are interspersed with commas before deserialization (see - -- ) -instance OVERLAPPING_ BuildHeadersTo '[] where +instance {-# OVERLAPPING #-} BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) - => BuildHeadersTo (Header h v ': xs) where - buildHeadersTo headers = - let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) - matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers - in case matching of - [] -> MissingHeader `HCons` buildHeadersTo headers - xs -> case parseHeader (BS.init $ BS.unlines xs) of - Left _err -> UndecodableHeader (BS.init $ BS.unlines xs) - `HCons` buildHeadersTo headers - Right h -> Header h `HCons` buildHeadersTo headers +-- The current implementation does not manipulate HTTP header field lines in any way, +-- like merging field lines with the same field name in a single line. +instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) + => BuildHeadersTo (Header' mods h v ': xs) where + buildHeadersTo headers = case L.find wantedHeader headers of + Nothing -> MissingHeader `HCons` buildHeadersTo headers + Just header@(_, val) -> case parseHeader val of + Left _err -> UndecodableHeader val `HCons` buildHeadersTo (L.delete header headers) + Right h -> Header h `HCons` buildHeadersTo (L.delete header headers) + where wantedHeader (h, _) = h == wantedHeaderName + wantedHeaderName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) --- * Getting +-- * Getting headers class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] @@ -111,7 +122,7 @@ getHeadersFromHList _ = [] instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs) - => GetHeadersFromHList (Header h x ': xs) + => GetHeadersFromHList (Header' mods h x ': xs) where getHeadersFromHList hdrs = case hdrs of Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest @@ -132,34 +143,53 @@ getHeaders' _ = [] instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v) - => GetHeaders' (Header h v ': rest) + => GetHeaders' (Header' mods h v ': rest) where getHeaders' hs = getHeadersFromHList $ getHeadersHList hs --- * Adding +-- * Adding headers -- We need all these fundeps to save type inference -class AddHeader h v orig new - | h v orig -> new, new -> h, new -> v, new -> orig where +class AddHeader (mods :: [Type]) h v orig new + | mods h v orig -> new, new -> mods, new -> h, new -> v, new -> orig where addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times - -instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v ) - => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where +-- In this instance, we add a Header on top of something that is already decorated with some headers +instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v ) + => AddHeader mods h v (Headers (fst ': rest) a) (Headers (Header' mods h v ': fst ': rest) a) where addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads) -instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v - , new ~ (Headers '[Header h v] a) ) - => AddHeader h v a new where +-- In this instance, 'a' parameter is decorated with a Header. +instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header' mods h v] a) + => AddHeader mods h v a new where addOptionalHeader hdr resp = Headers resp (HCons hdr HNil) +-- Instances to decorate all responses in a 'Union' with headers. The functional +-- dependencies force us to consider singleton lists as the base case in the +-- recursion (it is impossible to determine h and v otherwise from old / new +-- responses if the list is empty). +instance (AddHeader mods h v old new) => AddHeader mods h v (Union '[old]) (Union '[new]) where + addOptionalHeader hdr resp = + SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ resp + +instance + ( AddHeader mods h v old new, AddHeader mods h v (Union oldrest) (Union newrest) + -- This ensures that the remainder of the response list is _not_ empty + -- It is necessary to prevent the two instances for union types from + -- overlapping. + , oldrest ~ (a ': as), newrest ~ (b ': bs)) + => AddHeader mods h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where + addOptionalHeader hdr resp = case resp of + SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead + SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers + -- | @addHeader@ adds a header to a response. Note that it changes the type of -- the value in the following ways: -- -- 1. A simple value is wrapped in "Headers '[hdr]": -- --- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; --- >>> getHeaders example1 +-- >>> let example0 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; +-- >>> getHeaders example0 -- [("someheader","5")] -- -- 2. A value that already has a header has its new header *prepended* to the @@ -173,18 +203,62 @@ -- Note that while in your handlers type annotations are not required, since -- the type can be inferred from the API type, in other cases you may find -- yourself needing to add annotations. -addHeader :: AddHeader h v orig new => v -> orig -> new +addHeader :: AddHeader '[Optional, Strict] h v orig new => v -> orig -> new addHeader = addOptionalHeader . Header +-- | Same as 'addHeader' but works with `Header'`, so it's possible to use any @mods@. +addHeader' :: AddHeader mods h v orig new => v -> orig -> new +addHeader' = addOptionalHeader . Header + -- | Deliberately do not add a header to a value. -- -- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String -- >>> getHeaders example1 -- [] -noHeader :: AddHeader h v orig new => orig -> new +noHeader :: AddHeader '[Optional, Strict] h v orig new => orig -> new noHeader = addOptionalHeader MissingHeader +-- | Same as 'noHeader' but works with `Header'`, so it's possible to use any @mods@. +noHeader' :: AddHeader mods h v orig new => orig -> new +noHeader' = addOptionalHeader MissingHeader + +class HasResponseHeader h a headers where + hlistLookupHeader :: HList headers -> ResponseHeader h a + +instance {-# OVERLAPPING #-} HasResponseHeader h a (Header' mods h a ': rest) where + hlistLookupHeader (HCons ha _) = ha + +instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where + hlistLookupHeader (HCons _ hs) = hlistLookupHeader hs + +-- | Look up a specific ResponseHeader, +-- without having to know what position it is in the HList. +-- +-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String +-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String +-- >>> lookupResponseHeader example2 :: ResponseHeader "someheader" Int +-- Header 5 +-- +-- >>> lookupResponseHeader example2 :: ResponseHeader "1st" Bool +-- Header True +-- +-- Usage of this function relies on an explicit type annotation of the header to be looked up. +-- This can be done with type annotations on the result, or with an explicit type application. +-- In this example, the type of header value is determined by the type-inference, +-- we only specify the name of the header: +-- +-- >>> :set -XTypeApplications +-- >>> case lookupResponseHeader @"1st" example2 of { Header b -> b ; _ -> False } +-- True +-- +-- @since 0.15 +-- +lookupResponseHeader :: (HasResponseHeader h a headers) + => Headers headers r -> ResponseHeader h a +lookupResponseHeader = hlistLookupHeader . getHeadersHList + -- $setup +-- >>> :set -XFlexibleContexts -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text diff --git a/src/Servant/API/ServerSentEvents.hs b/src/Servant/API/ServerSentEvents.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/ServerSentEvents.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} + +-- | Server-sent events +-- +-- See . +-- +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 . +-- +data ServerSentEvents' (method :: k) (status :: Nat) (kind :: EventKind) (a :: Type) + deriving (Typeable, Generic) + +type ServerSentEvents = ServerSentEvents' 'GET 200 diff --git a/src/Servant/API/Status.hs b/src/Servant/API/Status.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Status.hs @@ -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 diff --git a/src/Servant/API/Stream.hs b/src/Servant/API/Stream.hs --- a/src/Servant/API/Stream.hs +++ b/src/Servant/API/Stream.hs @@ -1,25 +1,54 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Stream where -import Control.Arrow - (first) -import Data.ByteString.Lazy - (ByteString, empty) -import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Monoid - ((<>)) +{-# 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 @@ -30,111 +59,178 @@ (Nat) import Network.HTTP.Types.Method (StdMethod (..)) -import Text.Read - (readMaybe) +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. Stream endpoints always return response code 200 on success. Type synonyms are provided for standard methods. -data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *) +-- | 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 --- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation). -newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()} +-- | A stream request body. +type StreamBody = StreamBody' '[] --- | ToStreamGenerator 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 ToStreamGenerator a b | a -> b where - toStreamGenerator :: a -> StreamGenerator b +data StreamBody' (mods :: [Type]) (framing :: Type) (contentType :: Type) (a :: Type) + deriving (Typeable, Generic) -instance ToStreamGenerator (StreamGenerator a) a - where toStreamGenerator x = x +------------------------------------------------------------------------------- +-- Sources +------------------------------------------------------------------------------- --- | Clients reading from streaming endpoints can be implemented as producing a @ResultStream@ that captures the setup, takedown, and incremental logic for a read, being an IO continuation that takes a producer of Just either values or errors that terminates with a Nothing. -newtype ResultStream a = ResultStream (forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b) +-- | 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 --- | BuildFromStream 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 BuildFromStream a b where - buildFromStream :: ResultStream a -> b +-- | '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 -instance BuildFromStream a (ResultStream a) - where buildFromStream x = x +-- | Auxiliary class for @'ToSourceIO' x ('SourceT' m x)@ instance. +class SourceToSourceIO m where + sourceToSourceIO :: SourceT m a -> SourceT IO a --- | The FramingRender class provides the logic for emitting a framing strategy. The strategy emits a header, followed by boundary-delimited data, and finally a termination character. For many strategies, some of these will just be empty bytestrings. -class FramingRender strategy a where - header :: Proxy strategy -> Proxy a -> ByteString - boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy - trailer :: Proxy strategy -> Proxy a -> ByteString +instance SourceToSourceIO IO where + sourceToSourceIO = id --- | The bracketing strategy generates things to precede and follow the content, as with netstrings. --- The intersperse strategy inserts seperators between things, as with newline framing. --- Finally, the general strategy performs an arbitrary rewrite on the content, to allow escaping rules and such. -data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString)) - | BoundaryStrategyIntersperse ByteString - | BoundaryStrategyGeneral (ByteString -> ByteString) +-- | Relax to use auxiliary class, have m +instance SourceToSourceIO m => ToSourceIO chunk (SourceT m chunk) where + toSourceIO = sourceToSourceIO --- | A type of parser that can never fail, and has different parsing strategies (incremental, or EOF) depending if more input can be sent. The incremental parser should return `Nothing` if it would like to be sent a longer ByteString. If it returns a value, it also returns the remainder following that value. -data ByteStringParser a = ByteStringParser { - parseIncremental :: ByteString -> Maybe (a, ByteString), - parseEOF :: ByteString -> (a, ByteString) -} +instance ToSourceIO a (NonEmpty a) where + toSourceIO (x :| xs) = fromStepT (Yield x (foldr Yield Stop xs)) --- | The FramingUnrender class provides the logic for parsing a framing strategy. The outer @ByteStringParser@ strips the header from a stream of bytes, and yields a parser that can handle the remainder, stepwise. Each frame may be a ByteString, or a String indicating the error state for that frame. Such states are per-frame, so that protocols that can resume after errors are able to do so. Eventually this returns an empty ByteString to indicate termination. -class FramingUnrender strategy a where - unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString)) +instance ToSourceIO a [a] where + toSourceIO = source --- | 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 +-- | '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 a where - header _ _ = empty - boundary _ _ = BoundaryStrategyGeneral id - trailer _ _ = empty +instance FramingRender NoFraming where + framingRender _ = fmap -instance FramingUnrender NoFraming a where - unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,) - where go = ByteStringParser (Just . (, empty) . Right) ((, empty) . Right) +-- | 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 --- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame. --- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON). +------------------------------------------------------------------------------- +-- 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 a where - header _ _ = empty - boundary _ _ = BoundaryStrategyIntersperse "\n" - trailer _ _ = empty +instance FramingRender NewlineFraming where + framingRender _ f = fmap (\x -> f x <> "\n") -instance FramingUnrender NewlineFraming a where - unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,) - where go = ByteStringParser - (\x -> case LB.break (== '\n') x of - (h,r) -> if not (LB.null r) then Just (Right h, LB.drop 1 r) else Nothing - ) - (\x -> case LB.break (== '\n') x of - (h,r) -> (Right h, LB.drop 1 r) - ) --- | The netstring framing strategy as defined by djb: -data NetstringFraming +instance FramingUnrender NewlineFraming where + framingUnrender _ f = transformWithAtto $ do + bs <- A.takeWhile (/= 10) + () <$ A.word8 10 <|> A.endOfInput + either fail pure (f (LBS.fromStrict bs)) -instance FramingRender NetstringFraming a where - header _ _ = empty - boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",") - trailer _ _ = empty +------------------------------------------------------------------------------- +-- NetstringFraming +------------------------------------------------------------------------------- +-- | The netstring framing strategy as defined by djb: +-- +-- +-- 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 FramingUnrender NetstringFraming a where - unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,) - where go = ByteStringParser - (\b -> let (i,r) = LB.break (==':') b - in case readMaybe (LB.unpack i) of - Just len -> if LB.length r > len - then Just . first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r - else Nothing - Nothing -> Just (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r)) - (\b -> let (i,r) = LB.break (==':') b - in case readMaybe (LB.unpack i) of - Just len -> if LB.length r > len - then first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r - else (Right $ LB.take len r, LB.empty) - Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r)) +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)) diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs --- a/src/Servant/API/Sub.hs +++ b/src/Servant/API/Sub.hs @@ -4,6 +4,8 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Sub ((:>)) where +import Data.Kind + (Type) import Data.Typeable (Typeable) @@ -15,7 +17,7 @@ -- >>> -- GET /hello/world -- >>> -- returning a JSON encoded World value -- >>> type MyApi = "hello" :> "world" :> Get '[JSON] World -data (path :: k) :> (a :: *) +data (path :: k) :> (a :: Type) deriving (Typeable) infixr 4 :> diff --git a/src/Servant/API/TypeErrors.hs b/src/Servant/API/TypeErrors.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/TypeErrors.hs @@ -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 + ) diff --git a/src/Servant/API/TypeLevel.hs b/src/Servant/API/TypeLevel.hs --- a/src/Servant/API/TypeLevel.hs +++ b/src/Servant/API/TypeLevel.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + {-| This module collects utilities for manipulating @servant@ API types. The functionality in this module is for advanced usage. @@ -41,32 +45,39 @@ -- ** Logic Or, And, - -- * Custom type errors - -- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class, - -- which cannot be instantiated. + -- ** Fragment + FragmentUnique, + AtMostOneFragment ) where import GHC.Exts (Constraint) +import Data.Kind + (Type) import Servant.API.Alternative (type (:<|>)) import Servant.API.Capture (Capture, CaptureAll) +import Servant.API.Fragment import Servant.API.Header - (Header) + (Header, Header') import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.ReqBody (ReqBody) +import Servant.API.NamedRoutes + (NamedRoutes) +import Servant.API.Generic + (ToServantApi) import Servant.API.Sub (type (:>)) import Servant.API.Verbs (Verb) -#if MIN_VERSION_base(4,9,0) +import Servant.API.UVerb + (UVerb) import GHC.TypeLits (ErrorMessage (..), TypeError) -#endif @@ -105,7 +116,7 @@ -- -- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI)) -- ... --- ... Could not deduce... +-- ... Could not ... -- ... -- -- An endpoint is considered within an api even if it is missing combinators @@ -125,6 +136,7 @@ IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) IsElem (e :> sa) (e :> sb) = IsElem sa sb IsElem sa (Header sym x :> sb) = IsElem sa sb + IsElem sa (Header' mods sym x :> sb) = IsElem sa sb IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) = IsElem sa sb @@ -133,9 +145,11 @@ IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb + IsElem sa (Fragment x :> sb) = IsElem sa sb IsElem (Verb m s ct typ) (Verb m s ct' typ) = IsSubList ct ct' IsElem e e = () + IsElem e (NamedRoutes rs) = IsElem e (ToServantApi rs) IsElem e a = IsElem' e a -- | Check whether @sub@ is a sub-API of @api@. @@ -145,7 +159,7 @@ -- -- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI)) -- ... --- ... Could not deduce... +-- ... Could not ... -- ... -- -- This uses @IsElem@ for checking; thus the note there applies here. @@ -168,12 +182,13 @@ -- -- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))) -- ... --- ... Could not deduce... +-- ... Could not ... -- ... -type family IsIn (endpoint :: *) (api :: *) :: Constraint where +type family IsIn (endpoint :: Type) (api :: Type) :: Constraint where IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb) IsIn (e :> sa) (e :> sb) = IsIn sa sb IsIn e e = () + IsIn e (NamedRoutes record) = IsIn e (ToServantApi record) -- | Check whether @sub@ is a sub API of @api@. -- @@ -183,7 +198,7 @@ -- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@). -- --- ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI)) +-- >>> ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI)) -- OK type family AllIsIn xs api :: Constraint where AllIsIn '[] api = () @@ -222,47 +237,75 @@ type family ElemGo e es orig :: Constraint where ElemGo x (x ': xs) orig = () ElemGo y (x ': xs) orig = ElemGo y xs orig -#if MIN_VERSION_base(4,9,0) -- Note [Custom Errors] ElemGo x '[] orig = TypeError ('ShowType x ':<>: 'Text " expected in list " ':<>: 'ShowType orig) -#else - ElemGo x '[] orig = ElemNotFoundIn x orig -#endif -- ** Logic --- | If either a or b produce an empty constraint, produce an empty constraint. +-- | If either 'a' or 'b' produce an empty constraint, produce an empty constraint. type family Or (a :: Constraint) (b :: Constraint) :: Constraint where -- This works because of: -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap Or () b = () Or a () = () --- | If both a or b produce an empty constraint, produce an empty constraint. +-- | If both 'a' or 'b' produce an empty constraint, produce an empty constraint. type family And (a :: Constraint) (b :: Constraint) :: Constraint where And () () = () --- * Custom type errors - -#if !MIN_VERSION_base(4,9,0) -class ElemNotFoundIn val list -#endif - {- Note [Custom Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We might try to factor these our more cleanly, but the type synonyms and type families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -} +-- ** Fragment +-- | If there is more than one fragment in an API endpoint, +-- a compile-time error is raised. +-- +-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent +-- >>> instance AtMostOneFragment FailAPI +-- ... +-- ...Only one Fragment allowed per endpoint in api... +-- ... +class FragmentUnique api => AtMostOneFragment api + +instance AtMostOneFragment (Verb m s ct typ) + +instance AtMostOneFragment (UVerb m cts as) + +instance AtMostOneFragment (Fragment a) + +type family FragmentUnique api :: Constraint where + FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb) + FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa) + FragmentUnique (x :> sa) = FragmentUnique sa + FragmentUnique (Fragment a) = () + FragmentUnique x = () + +type family FragmentNotIn api orig :: Constraint where + FragmentNotIn (sa :<|> sb) orig = + And (FragmentNotIn sa orig) (FragmentNotIn sb orig) + FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig + FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn x orig = () + +type NotUniqueFragmentInApi api = + 'Text "Only one Fragment allowed per endpoint in api ‘" + ':<>: 'ShowType api + ':<>: 'Text "’." + -- $setup -- -- The doctests in this module are run with following preamble: -- -- >>> :set -XPolyKinds -- >>> :set -XGADTs +-- >>> :set -XTypeSynonymInstances -XFlexibleInstances -- >>> import Data.Proxy -- >>> import Data.Type.Equality -- >>> import Servant.API @@ -270,4 +313,5 @@ -- >>> instance Show (OK ctx) where show _ = "OK" -- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK -- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool +-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent -- >>> let sampleAPI = Proxy :: Proxy SampleAPI diff --git a/src/Servant/API/TypeLevel/List.hs b/src/Servant/API/TypeLevel/List.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/TypeLevel/List.hs @@ -0,0 +1,14 @@ +module Servant.API.TypeLevel.List + (type (.++) + ) where + +import Data.Kind + +-- | Append two type-level lists. +-- +-- Import it as +-- +-- > import Servant.API.TypeLevel.List (type (.++)) +type family (.++) (l1 :: [Type]) (l2 :: [Type]) where + '[] .++ a = a + (a ': as) .++ b = a ': (as .++ b) diff --git a/src/Servant/API/UVerb.hs b/src/Servant/API/UVerb.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/UVerb.hs @@ -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 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 diff --git a/src/Servant/API/UVerb/Union.hs b/src/Servant/API/UVerb/Union.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/UVerb/Union.hs @@ -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 diff --git a/src/Servant/API/Verbs.hs b/src/Servant/API/Verbs.hs --- a/src/Servant/API/Verbs.hs +++ b/src/Servant/API/Verbs.hs @@ -1,13 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} + {-# LANGUAGE PolyKinds #-} module Servant.API.Verbs ( module Servant.API.Verbs , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH) ) where +import Data.Kind + (Type) import Data.Proxy (Proxy) import Data.Typeable @@ -26,9 +28,15 @@ -- provided, but you are free to define your own: -- -- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a -data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *) +data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type) deriving (Typeable, Generic) +-- | @NoContentVerb@ is a specific type to represent 'NoContent' responses. +-- It does not require either a list of content types (because there's +-- no content) or a status code (because it should always be 204). +data NoContentVerb (method :: k1) + deriving (Typeable, Generic) + -- * 200 responses -- -- The 200 response is the workhorse of web servers, but also fairly generic. @@ -56,14 +64,17 @@ -- Indicates that a new resource has been created. The URI corresponding to the -- resource should be given in the @Location@ header field. -- +-- If the operation is idempotent, use 'PutCreated'. If not, use 'PostCreated' +-- -- If the resource cannot be created immediately, use 'PostAccepted'. -- --- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header +-- Consider using 'Servant.Links.safeLink' for the @Location@ header -- field. -- | 'POST' with 201 status code. --- type PostCreated = Verb 'POST 201 +-- | 'PUT' with 201 status code. +type PutCreated = Verb 'PUT 201 -- ** 202 Accepted @@ -110,16 +121,17 @@ -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code. -type GetNoContent = Verb 'GET 204 +type GetNoContent = NoContentVerb 'GET -- | 'POST' with 204 status code. -type PostNoContent = Verb 'POST 204 +type PostNoContent = NoContentVerb 'POST -- | 'DELETE' with 204 status code. -type DeleteNoContent = Verb 'DELETE 204 +type DeleteNoContent = NoContentVerb 'DELETE -- | 'PATCH' with 204 status code. -type PatchNoContent = Verb 'PATCH 204 +type PatchNoContent = NoContentVerb 'PATCH -- | 'PUT' with 204 status code. -type PutNoContent = Verb 'PUT 204 - +type PutNoContent = NoContentVerb 'PUT +-- | 'HEAD' with 204 status code. +type HeadNoContent = NoContentVerb 'HEAD -- ** 205 Reset Content -- diff --git a/src/Servant/API/WithNamedContext.hs b/src/Servant/API/WithNamedContext.hs --- a/src/Servant/API/WithNamedContext.hs +++ b/src/Servant/API/WithNamedContext.hs @@ -4,6 +4,8 @@ module Servant.API.WithNamedContext where import GHC.TypeLits +import Data.Kind + (Type) -- | 'WithNamedContext' names a specific tagged context to use for the -- combinators in the API. (See also in @servant-server@, @@ -18,4 +20,4 @@ -- 'Context's are only relevant for @servant-server@. -- -- For more information, see the tutorial. -data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi +data WithNamedContext (name :: Symbol) (subContext :: [Type]) subApi diff --git a/src/Servant/API/WithResource.hs b/src/Servant/API/WithResource.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/WithResource.hs @@ -0,0 +1,3 @@ +module Servant.API.WithResource (WithResource) where + +data WithResource res diff --git a/src/Servant/Links.hs b/src/Servant/Links.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Links.hs @@ -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 diff --git a/src/Servant/Test/ComprehensiveAPI.hs b/src/Servant/Test/ComprehensiveAPI.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Test/ComprehensiveAPI.hs @@ -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 diff --git a/src/Servant/Types/Internal/Response.hs b/src/Servant/Types/Internal/Response.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Types/Internal/Response.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveTraversable #-} + +-- | This module offers other servant libraries a minimalistic HTTP response type. +-- +-- It is purely an internal API and SHOULD NOT be used by end-users of Servant. +module Servant.Types.Internal.Response where + +import Network.HTTP.Types (Status, Header) +import Data.Sequence (Seq) +import GHC.Generics (Generic) +import Data.Data (Typeable) + +data InternalResponse a = InternalResponse + { statusCode :: Status + , headers :: Seq Header + , responseBody :: a + } deriving stock (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) diff --git a/src/Servant/Types/SourceT.hs b/src/Servant/Types/SourceT.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Types/SourceT.hs @@ -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) diff --git a/src/Servant/Utils/Enter.hs b/src/Servant/Utils/Enter.hs deleted file mode 100644 --- a/src/Servant/Utils/Enter.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} ( - module Servant.Utils.Enter, - -- * natural-transformation re-exports - (:~>)(..), - ) where - -import Control.Monad.Identity -import Control.Monad.Morph -import Control.Monad.Reader -import qualified Control.Monad.State.Lazy as LState -import qualified Control.Monad.State.Strict as SState -import qualified Control.Monad.Writer.Lazy as LWriter -import qualified Control.Monad.Writer.Strict as SWriter -import Control.Natural -import Data.Tagged - (Tagged, retag) -import Prelude () -import Prelude.Compat -import Servant.API - --- | Helper type family to state the 'Enter' symmetry. -type family Entered m n api where - Entered m n (a -> api) = a -> Entered m n api - Entered m n (m a) = n a - Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2 - Entered m n (Tagged m a) = Tagged n a - -class - ( Entered m n typ ~ ret - , Entered n m ret ~ typ - ) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m - where - -- | Map the leafs of an API type. - enter :: (m :~> n) -> typ -> ret - --- ** Servant combinators - -instance - ( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2 - , m1 ~ m2, n1 ~ n2 - , Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2) - , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2) - ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2) - where - enter e (a :<|> b) = enter e a :<|> enter e b - -instance - ( Enter typ m n ret - , Entered m n (a -> typ) ~ (a -> ret) - , Entered n m (a -> ret) ~ (a -> typ) - ) => Enter (a -> typ) m n (a -> ret) - where - enter arg f a = enter arg (f a) - --- ** Leaf instances - -instance - ( Entered m n (Tagged m a) ~ Tagged n a - , Entered n m (Tagged n a) ~ Tagged m a - ) => Enter (Tagged m a) m n (Tagged n a) - where - enter _ = retag - -instance - ( Entered m n (m a) ~ n a - , Entered n m (n a) ~ m a - ) => Enter (m a) m n (n a) - where - enter (NT f) = f - --- | Like `lift`. -liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m -liftNat = NT Control.Monad.Morph.lift - -runReaderTNat :: r -> (ReaderT r m :~> m) -runReaderTNat a = NT (`runReaderT` a) - -evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) -evalStateTLNat a = NT (`LState.evalStateT` a) - -evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) -evalStateTSNat a = NT (`SState.evalStateT` a) - --- | Log the contents of `SWriter.WriterT` with the function provided as the --- first argument, and return the value of the @WriterT@ computation -logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m) -logWriterTSNat logger = NT $ \x -> do - (a, w) <- SWriter.runWriterT x - liftIO $ logger w - return a - --- | Like `logWriterTSNat`, but for lazy @WriterT@. -logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) -logWriterTLNat logger = NT $ \x -> do - (a, w) <- LWriter.runWriterT x - liftIO $ logger w - return a - --- | Like @mmorph@'s `hoist`. -hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n) -hoistNat (NT n) = NT $ hoist n - --- | Like @mmorph@'s `embed`. -embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) -embedNat (NT n) = NT $ embed n - --- | Like @mmorph@'s `squash`. -squashNat :: (Monad m, MMonad t) => t (t m) :~> t m -squashNat = NT squash - --- | Like @mmorph@'s `generalize`. -generalizeNat :: Applicative m => Identity :~> m -generalizeNat = NT (pure . runIdentity) diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs deleted file mode 100644 --- a/src/Servant/Utils/Links.hs +++ /dev/null @@ -1,487 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_HADDOCK not-home #-} - --- | Type safe generation of internal links. --- --- Given an API with a few endpoints: --- --- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators --- >>> import Servant.API --- >>> import Servant.Utils.Links --- >>> import Data.Proxy --- >>> --- >>> type Hello = "hello" :> Get '[JSON] Int --- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent --- >>> type API = Hello :<|> Bye --- >>> let api = Proxy :: Proxy API --- --- It is possible to generate links that are guaranteed to be within 'API' with --- 'safeLink'. The first argument to 'safeLink' is a type representing the API --- you would like to restrict links to. The second argument is the destination --- endpoint you would like the link to point to, this will need to end with a --- verb like GET or POST. Further arguments may be required depending on the --- type of the endpoint. If everything lines up you will get a 'Link' out the --- other end. --- --- You may omit 'QueryParam's and the like should you not want to provide them, --- but types which form part of the URL path like 'Capture' must be included. --- The reason you may want to omit 'QueryParam's is that safeLink is a bit --- magical: if parameters are included that could take input it will return a --- function that accepts that input and generates a link. This is best shown --- with an example. Here, a link is generated with no parameters: --- --- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int) --- >>> toUrlPiece (safeLink api hello :: Link) --- "hello" --- --- If the API has an endpoint with parameters then we can generate links with --- or without those: --- --- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent) --- >>> toUrlPiece $ safeLink api with (Just "Hubert") --- "bye?name=Hubert" --- --- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent) --- >>> toUrlPiece $ safeLink api without --- "bye" --- --- If you would like create a helper for generating links only within that API, --- you can partially apply safeLink if you specify a correct type signature --- like so: --- --- >>> :set -XConstraintKinds --- >>> :{ --- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) --- >>> => Proxy endpoint -> MkLink endpoint Link --- >>> apiLink = safeLink api --- >>> :} --- --- `safeLink'` allows to make 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 deduce... --- ... --- --- This error is essentially saying that the type family couldn't find --- bad_link under api after trying the open (but empty) type family --- `IsElem'` as a last resort. -module Servant.Utils.Links ( - module Servant.API.TypeLevel, - - -- * Building and using safe links - -- - -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. - safeLink - , safeLink' - , allLinks - , allLinks' - , URI(..) - -- * Adding custom types - , HasLink(..) - , Link - , linkURI - , linkURI' - , LinkArrayElementStyle (..) - -- ** Link accessors - , Param (..) - , linkSegments - , linkQueryParams -) where - -import Data.List -import Data.Proxy - (Proxy (..)) -import Data.Semigroup - ((<>)) -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, symbolVal) -import Network.URI - (URI (..), escapeURIString, isUnreserved) -import Prelude () -import Prelude.Compat - -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.Header - (Header') -import Servant.API.HttpVersion - (HttpVersion) -import Servant.API.IsSecure - (IsSecure) -import Servant.API.Modifiers - (FoldRequired) -import Servant.API.QueryParam - (QueryFlag, QueryParam', QueryParams) -import Servant.API.Raw - (Raw) -import Servant.API.RemoteHost - (RemoteHost) -import Servant.API.ReqBody - (ReqBody') -import Servant.API.Stream - (Stream) -import Servant.API.Sub - (type (:>)) -import Servant.API.TypeLevel -import Servant.API.Vault - (Vault) -import Servant.API.Verbs - (Verb) -import Servant.API.WithNamedContext - (WithNamedContext) -import Web.HttpApiData - --- | A safe link datatype. --- The only way of constructing a 'Link' is using 'safeLink', which means any --- 'Link' is guaranteed to be part of the mentioned API. -data Link = Link - { _segments :: [Escaped] - , _queryParams :: [Param] - } deriving Show - -newtype Escaped = Escaped String - -escaped :: String -> Escaped -escaped = Escaped . escapeURIString isUnreserved - -getEscaped :: Escaped -> String -getEscaped (Escaped s) = s - -instance Show Escaped where - showsPrec d (Escaped s) = showsPrec d s - show (Escaped s) = show s - -linkSegments :: Link -> [String] -linkSegments = map getEscaped . _segments - -linkQueryParams :: Link -> [Param] -linkQueryParams = _queryParams - -instance ToHttpApiData Link where - toHeader = TE.encodeUtf8 . toUrlPiece - toUrlPiece l = - let uri = linkURI l - in Text.pack $ uriPath uri ++ uriQuery uri - --- | Query parameter. -data Param - = SingleParam String Text.Text - | ArrayElemParam String Text.Text - | FlagParam String - deriving Show - -addSegment :: Escaped -> Link -> Link -addSegment seg l = l { _segments = _segments l <> [seg] } - -addQueryParam :: Param -> Link -> Link -addQueryParam qp l = - l { _queryParams = _queryParams l <> [qp] } - --- | Transform 'Link' into 'URI'. --- --- >>> type API = "something" :> Get '[JSON] Int --- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) --- something --- --- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int --- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] --- sum?x[]=1&x[]=2&x[]=3 --- --- >>> type API = "foo/bar" :> Get '[JSON] Int --- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) --- foo%2Fbar --- --- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] () --- >>> let someRoute = Proxy :: Proxy SomeRoute --- >>> safeLink someRoute someRoute "test@example.com" --- Link {_segments = ["abc","test%40example.com"], _queryParams = []} --- --- >>> linkURI $ safeLink someRoute someRoute "test@example.com" --- abc/test%40example.com --- -linkURI :: Link -> URI -linkURI = linkURI' LinkArrayElementBracket - --- | How to encode array query elements. -data LinkArrayElementStyle - = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@ - | LinkArrayElementPlain -- ^ @foo=1&foo=2@ - deriving (Eq, Ord, Show, Enum, Bounded) - --- | Configurable 'linkURI'. --- --- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int --- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] --- sum?x[]=1&x[]=2&x[]=3 --- --- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] --- sum?x=1&x=2&x=3 --- -linkURI' :: LinkArrayElementStyle -> Link -> URI -linkURI' addBrackets (Link segments q_params) = - URI mempty -- No scheme (relative) - Nothing -- Or authority (relative) - (intercalate "/" $ map getEscaped segments) - (makeQueries q_params) mempty - where - makeQueries :: [Param] -> String - makeQueries [] = "" - makeQueries xs = - "?" <> intercalate "&" (fmap makeQuery xs) - - makeQuery :: Param -> String - makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v) - makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) - makeQuery (FlagParam k) = escape k - - style = case addBrackets of - LinkArrayElementBracket -> "[]=" - LinkArrayElementPlain -> "=" - -escape :: String -> String -escape = escapeURIString isUnreserved - --- | Create a valid (by construction) relative URI with query params. --- --- This function will only typecheck if `endpoint` is part of the API `api` -safeLink - :: forall endpoint api. (IsElem endpoint api, HasLink endpoint) - => Proxy api -- ^ The whole API that this endpoint is a part of - -> Proxy endpoint -- ^ The API endpoint you would like to point to - -> MkLink endpoint 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) - --- | 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 :: * --- = 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) - --- | Construct a toLink for an endpoint. -class HasLink endpoint where - type MkLink endpoint (a :: *) - 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) . - 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 (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) $ - foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs - -instance HasLink sub => HasLink (Header' mods sym (a :: *) :> 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 (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 Raw where - type MkLink Raw a = a - toLink toA _ = toA - -instance HasLink (Stream m fr ct a) where - type MkLink (Stream m fr ct a) r = r - toLink toA _ = toA - --- AuthProtext instances -instance HasLink sub => HasLink (AuthProtect tag :> sub) where - type MkLink (AuthProtect tag :> sub) a = MkLink sub a - toLink = simpleToLink (Proxy :: Proxy sub) - --- | Helper for implemneting 'toLink' for combinators not affecting link --- 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) diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs --- a/test/Servant/API/ContentTypesSpec.hs +++ b/test/Servant/API/ContentTypesSpec.hs @@ -8,29 +8,34 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where -import Prelude () -import Prelude.Compat - -import Data.Aeson.Compat -import Data.ByteString.Char8 (ByteString, append, pack) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSL8 +import Data.Aeson (FromJSON, ToJSON (..), Value, decode, encode, object, (.=), eitherDecode) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Either -import Data.Function (on) -import Data.List (maximumBy) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust, isJust, isNothing) +import Data.Function + (on) +import Data.List + (sortBy) +import qualified Data.List.NonEmpty as NE +import Data.Maybe + (fromJust, isJust, isNothing) import Data.Proxy -import Data.String (IsString (..)) -import Data.String.Conversions (cs) -import qualified Data.Text as TextS -import qualified Data.Text.Encoding as TextSE -import qualified Data.Text.Lazy as TextL +import Data.String + (IsString (..)) +import qualified Data.Text as TextS +import qualified Data.Text.Encoding as TextSE +import qualified Data.Text.Lazy as TextL +import Control.Exception + (evaluate) import GHC.Generics import Test.Hspec +import Network.HTTP.Media () -- for CPP import Test.QuickCheck -import Text.Read (readMaybe) -import "quickcheck-instances" Test.QuickCheck.Instances () +import "quickcheck-instances" Test.QuickCheck.Instances () +import Text.Read + (readMaybe) import Servant.API.ContentTypes @@ -70,6 +75,15 @@ it "has mimeUnrender reverse mimeRender for valid top-level json " $ do property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData) + describe "The NoContent Content-Type type" $ do + let p = Proxy :: Proxy '[JSON] + + it "does not render any content" $ + allMimeRender p NoContent `shouldSatisfy` all (BSL8.null . snd) + + it "evaluates the NoContent value" $ + evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall + describe "The PlainText Content-Type type" $ do let p = Proxy :: Proxy PlainText @@ -127,17 +141,28 @@ == Just ("application/json;charset=utf-8", encode x) it "respects the Accept spec ordering" $ do - let highest a b c = maximumBy (compare `on` snd) + let highest a b c = last $ sortBy (compare `on` snd) +-- when qualities are same, http-media-0.8 picks first; 0.7 last. +#if MIN_VERSION_http_media(0,8,0) + [ ("text/plain;charset=utf-8", c) + , ("application/json;charset=utf-8", b) + , ("application/octet-stream", a) + ] +#else [ ("application/octet-stream", a) , ("application/json;charset=utf-8", b) , ("text/plain;charset=utf-8", c) ] +#endif let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $ - addToAccept (Proxy :: Proxy JSON) b $ - addToAccept (Proxy :: Proxy PlainText ) c "" + addToAccept (Proxy :: Proxy JSON) b $ + addToAccept (Proxy :: Proxy PlainText ) c "" let val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText]) (acceptH a b c) (i :: Int) - property $ \a b c i -> fst (fromJust $ val a b c i) == fst (highest a b c) + property $ \a b c i -> + let acc = acceptH a b c + in counterexample (show acc) $ + fst (fromJust $ val a b c i) === fst (highest a b c) describe "handleCTypeH" $ do @@ -188,17 +213,13 @@ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" "foobar" `shouldBe` (Nothing :: Maybe (Either String Int)) -#if MIN_VERSION_aeson(0,9,0) - -- aeson >= 0.9 decodes top-level strings - describe "eitherDecodeLenient" $ do + describe "eitherDecode is lenient" $ do + -- Since servant-0.20.1 MimeUnrender JSON instance uses eitherDecode, + -- as aeson >= 0.9 supports decoding top-level strings and numbers. it "parses top-level strings" $ do - let toMaybe = either (const Nothing) Just - -- The Left messages differ, so convert to Maybe - property $ \x -> toMaybe (eitherDecodeLenient x) - `shouldBe` (decode x :: Maybe String) -#endif - + property $ \x -> mimeUnrender (Proxy :: Proxy JSON) x + `shouldBe` (eitherDecode x :: Either String String) data SomeData = SomeData { record1 :: String, record2 :: Int } deriving (Generic, Eq, Show) @@ -217,13 +238,13 @@ arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] instance MimeRender OctetStream Int where - mimeRender _ = cs . show + mimeRender _ = BSL8.pack . show instance MimeRender PlainText Int where - mimeRender _ = cs . show + mimeRender _ = BSL8.pack . show instance MimeRender PlainText ByteString where - mimeRender _ = cs + mimeRender _ = BSL.fromStrict instance ToJSON ByteString where toJSON x = object [ "val" .= x ] @@ -238,7 +259,7 @@ contentTypes _ = "text/plain" NE.:| [ "application/json" ] instance MimeRender JSONorText Int where - mimeRender _ = cs . show + mimeRender _ = BSL8.pack . show instance MimeUnrender JSONorText Int where mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack @@ -250,6 +271,6 @@ addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) - where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) + where new = BS8.pack (show $ contentType p) <> "; q=" <> BS8.pack (show f) cont "" = new - cont old = old `append` ", " `append` new + cont old = old <> ", " <> new diff --git a/test/Servant/API/ResponseHeadersSpec.hs b/test/Servant/API/ResponseHeadersSpec.hs --- a/test/Servant/API/ResponseHeadersSpec.hs +++ b/test/Servant/API/ResponseHeadersSpec.hs @@ -1,11 +1,19 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Servant.API.ResponseHeadersSpec where -import Test.Hspec +import Data.Proxy +import GHC.TypeLits +import Test.Hspec -import Servant.API.Header -import Servant.API.ResponseHeaders +import Servant.API.ContentTypes +import Servant.API.Description + (Description) +import Servant.API.Header +import Servant.API.Modifiers + (Optional, Strict) +import Servant.API.ResponseHeaders +import Servant.API.UVerb spec :: Spec spec = describe "Servant.API.ResponseHeaders" $ do @@ -23,8 +31,19 @@ let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int getHeaders val `shouldBe` [("first", "10"), ("second", "b")] + it "adds a header with description to a value" $ do + let val = addHeader' "hi" 5 :: Headers '[Header' '[Description "desc", Optional, Strict] "test" String] Int + getHeaders val `shouldBe` [("test", "hi")] + describe "noHeader" $ do it "does not add a header" $ do let val = noHeader 5 :: Headers '[Header "test" Int] Int getHeaders val `shouldBe` [] + + describe "HasStatus Headers" $ do + + it "gets the status from the underlying value" $ do + natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204 + natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503 + diff --git a/test/Servant/API/StreamSpec.hs b/test/Servant/API/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/API/StreamSpec.hs @@ -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) diff --git a/test/Servant/LinksSpec.hs b/test/Servant/LinksSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/LinksSpec.hs @@ -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) +-- ... +-- ... +-- ... +-- +-- 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 diff --git a/test/Servant/Utils/EnterSpec.hs b/test/Servant/Utils/EnterSpec.hs deleted file mode 100644 --- a/test/Servant/Utils/EnterSpec.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} -module Servant.Utils.EnterSpec where - -import Test.Hspec (Spec) - -import Servant.API -import Servant.Utils.Enter - -------------------------------------------------------------------------------- --- https://github.com/haskell-servant/servant/issues/734 -------------------------------------------------------------------------------- - --- This didn't fail if executed in GHCi; cannot have as a doctest. - -data App a - -f :: App :~> App -f = NT id - -server :: App Int :<|> (String -> App Bool) -server = undefined - -server' :: App Int :<|> (String -> App Bool) -server' = enter f server - -------------------------------------------------------------------------------- --- Spec -------------------------------------------------------------------------------- - -spec :: Spec -spec = return () diff --git a/test/Servant/Utils/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs deleted file mode 100644 --- a/test/Servant/Utils/LinksSpec.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ < 709 -{-# OPTIONS_GHC -fcontext-stack=41 #-} -#endif -module Servant.Utils.LinksSpec where - -import Data.Proxy (Proxy (..)) -import Test.Hspec (Expectation, Spec, describe, it, - shouldBe) -import Data.String (fromString) - -import Servant.API -import Servant.Utils.Links -import Servant.API.Internal.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 - - -- 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) - --- | Convert a link to a URI and ensure that this maps to the given string --- given string -shouldBeLink :: Link -> String -> Expectation -shouldBeLink link expected = - toUrlPiece link `shouldBe` fromString expected - -spec :: Spec -spec = describe "Servant.Utils.Links" $ do - it "generates correct links for capture query params" $ do - let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent) - apiLink l1 "hi" `shouldBeLink` "hello/hi" - - let l2 = Proxy :: Proxy ("hello" :> Capture "name" String - :> QueryParam "capital" Bool - :> Delete '[JSON] NoContent) - apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true" - - 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 "generates correct links for query flags" $ do - let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" - :> QueryFlag "fast" :> Delete '[JSON] NoContent) - apiLink l1 True True `shouldBeLink` "balls?bouncy&fast" - apiLink l1 False True `shouldBeLink` "balls?fast" - - it "generates correct links for all of the verbs" $ do - apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get" - apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put" - apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post" - apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete" - apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw" - - it "can generate all links for an API that has only linkable endpoints" $ do - let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi) - simple `shouldBeLink` "get" - allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius" - - it "can generate all links for ComprehensiveAPIWithoutRaw" $ do - let (firstLink :<|> _) = allLinks comprehensiveAPIWithoutRaw - firstLink `shouldBeLink` "" - --- | --- 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) --- ... --- ... --- ... --- --- 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 diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources