diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,1030 @@ +[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) + +Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. + +0.20.3.0 +---- + +### Significant changes + +- Remove -XStrictData from servant{,-server}'s cabal files [#1780](https://github.com/haskell-servant/servant/issues/1780) [#1781](https://github.com/haskell-servant/servant/pull/1781) + + The addition of -XStrictData to servant.cabal and servant-server.cabal reduced the laziness + of routing, which would trigger unimplemented endpoints using `error` or `undefined`, + despite the fact that these endpoints themselves were not queried. + +### Other changes + +- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811) + + Implement Server-sent events (SSE) for the Servant client using a new + combinator "ServerSentEvents". The raw event messages, accumulated events and + JSON-processed events can be exposed. + +- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804) + + Expose MultiVerb, a more ergonomic way of defining endpoints that return + many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html + +- Exported addQueryParam [#1232](https://github.com/haskell-servant/servant/issues/1232) [#1785](https://github.com/haskell-servant/servant/pull/1785) + + `addQueryParams` is required to define custom `HasLink` instances which actually manipulate the + generated query params. This function was not exported earlier and now it is. + +- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800) + + Adding a Host combinator allows servant users to select APIs according + to the Host header provided by clients. + +- Use newtype deriving for ToHttpApiData in the type Range [#1813](https://github.com/haskell-servant/servant/pull/1813) + +- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706) +- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778) +- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805) +- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784) [#1814](https://github.com/haskell-servant/servant/pull/1814) + +0.20.2 +---- +- Full query string helpers [#1604](https://github.com/haskell-servant/servant/pull/1604) + + This PR introduces `DeepQuery`, a route combinator that implements a pattern commonly known as deep objects. + It builds upon the convention of using `[]` for a list of parameters: + `books?filter[search]=value&filter[author][name]=value`. + The corresponding type would be `DeepQuery "filter" BookQuery :> Get '[JSON] [Book]`. +- Add IsIn instance for NamedRoutes [#1707](https://github.com/haskell-servant/servant/pull/1707) +- Renamed `AtLeastOneFragment` type class to `AtMostOneFragment` [#1727](https://github.com/haskell-servant/servant/pull/1727) + + The previously named `AtLeastOneFragment` type class defined in the + `Servant.API.TypeLevel` module has been renamed to `AtMostOneFragment`, + since the previous name was misleading. +- Use `Header'` in response headers. [#1697](https://github.com/haskell-servant/servant/pull/1697) + + Use `Header'` instead of `Header` in response, so it's possible to provide + `Description`, for example: + + ``` + type PaginationTotalCountHeader = + Header' + '[ Description "Indicates to the client total count of items in collection" + , Optional + , Strict + ] + "Total-Count" + Int + ``` + + Note: if you want to add header with description you should use `addHeader'` + or `noHeader'` which accepts `Header'` with all modifiers. + + +0.20.1 +---- + +- Support aeson-2.2 [#1695](https://github.com/haskell-servant/servant/pull/1695) + +0.20 +---- + +- Headers support in UVerb responses [#1570](https://github.com/haskell-servant/servant/issues/1570) [#1571](https://github.com/haskell-servant/servant/pull/1571) +- Generalize type of `Servant.Types.SourceT.source` to any foldable [#1593](https://github.com/haskell-servant/servant/pull/1593) +- Make `Mime(Un)Render PlainText String` instances encode/decode UTF-8 [#1645](https://github.com/haskell-servant/servant/issues/1645) +- Add HasStatus instance for Headers (that defers StatusOf to underlying value) [#1649](https://github.com/haskell-servant/servant/pull/1649) +- Make fromSourceIO run in IO [#1661](https://github.com/haskell-servant/servant/pull/1661) + + Some streaming abstractions, like io-streams, require stateful + initialization. Since all actual call sites of `fromSourceIO` + are in a context where `IO` actions can be executed, these + streaming sources can be accomodated by having letting + `fromSourceIO` run in `IO`. + + To migrate your existing `FromSourceIO` instance, simply put + a `pure`/`return` in front of it. + +- Fix the handling of multiple headers with the same name. [#1666](https://github.com/haskell-servant/servant/pull/1666) + +0.19.1 +------ + +Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592). + +0.19 +---- + +### Significant changes + +- Drop support for GHC < 8.6. +- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). +- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), + which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) + related to hash collisions. +- Add `NamedRoutes` combinator, making support for records first-class in Servant + ([#1388](https://github.com/haskell-servant/servant/pull/1388)). + + Users can now directly mark part as an API as defined by a record, instead of + using `(:<|>)` to combine routes. Concretely, the anonymous: + + ```haskell + type API = + "version" :> Get '[JSON] String :<|> + "products" :> Get '[JSON] [Product] + ``` + + can be replaced with the explicitly-named: + + ```haskell + type API = NamedRoutes NamedAPI + data NamedAPI mode = NamedAPI + { version :: mode :- "version" :> Get '[JSON] String + , products :: mode :- "products" :> Get '[JSON] [Product] + } + ``` + + `NamedRoutes` builds upon `servant-generic`, but improves usability by freeing + users from the need to perform `toServant` / `fromServant` conversions + manually. Serving `NamedRoutes NamedAPI` is now done directly by providing a + record of handlers, and servant generates clients directly as records as well. + In particular, it makes it much more practical to work with nested hierarchies + of named routes. + + Two convenience functions, `(//)` and `(/:)`, have been added to make the + usage of named route hierarchies more pleasant: + + ```haskell + rootClient :: RootApi (AsClientT ClientM) + rootClient = client (Proxy @API) + + helloClient :: String -> ClientM String + helloClient name = rootClient // hello /: name + + endpointClient :: ClientM Person + endpointClient = rootClient // subApi /: "foobar123" // endpoint + + type Api = NamedRoutes RootApi + + data RootApi mode = RootApi + { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi + , hello :: mode :- Capture "name" String :> Get '[JSON] String + , … + } deriving Generic + + data SubApi mode = SubApi + { endpoint :: mode :- Get '[JSON] Person + , … + } deriving Generic + ``` + +- Add custom type errors for partially applied combinators + ([#1289](https://github.com/haskell-servant/servant/pull/1289), + [#1486](https://github.com/haskell-servant/servant/pull/1486)). + + For example, forgetting to document the expected type for a query parameter, + as in: + + ``` haskell + type API = QueryParam "param" :> Get '[JSON] NoContent + ``` + + will raise to the following error when trying to serve the API: + + ``` + • There is no instance for HasServer (QueryParam' + '[Optional, Strict] "param" :> ...) + QueryParam' '[Optional, Strict] "1" expects 1 more arguments + ``` + + As a consequence of this change, unsaturated types are now forbidden before `(:>)`. + +- Add a `HeadNoContent` verb ([#1502](https://github.com/haskell-servant/servant/pull/1502)). + +- *servant-client* / *servant-client-core* / *servant-http-streams*: + Fix erroneous behavior, where only 2XX status codes would be considered + successful, irrelevant of the status parameter specified by the verb + combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469)) + +- *servant-client* / *servant-client-core*: Fix `Show` instance for + `Servant.Client.Core.Request`. + + +- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data + in Query parameters. + ([#1432](https://github.com/haskell-servant/servant/pull/1432)). + +- *servant-docs*: Generate sample cURL requests + ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)). + + Breaking change: requires sample header values to be supplied with `headers`. + +### Other changes + +- Various bit rotten cookbooks have been updated and re-introduced on + [docs.servant.dev](https://docs.servant.dev). + +- Various version bumps. + +0.18.3 +------ + +### Significant changes + +- Add response header support to UVerb (#1420). +- Use Capture Description if available (#1423). + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring`, `attoparsec`, `hspec` and `singleton-bool` dependencies. + +0.18.2 +------ + +### Significant changes + +- Introduce `Fragment` combinator. +- Fix `MimeRender` and `MimeUnrender` instances for `WithStatus`. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions +- Allow newer dependencies + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + +- Configurable error messages for automatic errors thrown by servant, + like "no route" or "could not parse json body" (#1312, #1326, #1327) + +### Other changes + +- Witness that a type-level natural number corresponds to a HTTP + status code (#1310) + +- Improve haddocs (#1279) + +- Dependency management (#1269, #1293, #1286, #1287) + + +0.17 +---- + +### Significant changes + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + The `NoContent` API endpoints should now use `NoContentVerb` combinator. + The API type changes are usually of the kind + + ```diff + - :<|> PostNoContent '[JSON] NoContent + + :<|> PostNoContent + ``` + + i.e. one doesn't need to specify the content-type anymore. There is no content. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + You can specify a lenient capture as + + ```haskell + :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET + ``` + + which will make the capture always succeed. Handlers will be of the + type `Either String CapturedType`, where `Left err` represents + the possible parse failure. + +- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255) + + The new member `makeClientRequest` of `ClientEnv` is used to create + `http-client` `Request` from `servant-client-core` `Request`. + This functionality can be used for example to set + dynamic timeouts for each request. + +- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262) + + Some APIs need query parameters rewriting, e.g. in order to support + for multiple casing (camel, snake, etc) or something to that effect. + + This could be easily achieved by using WAI Middleware and modifying + request's `Query`. But QueryParam, QueryParams and QueryFlag use + `rawQueryString`. By using `queryString` rather then `rawQueryString` + we can enable such rewritings. + +- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263) + + We used `build-type: Custom`, but it's problematic e.g. + for cross-compiling. The benefit is small, as the doctests + can be run other ways too (though not so conveniently). + +- *servant* Remove deprecated modules [1268#](https://github.com/haskell-servant/servant/pull/1268) + + - `Servant.Utils.Links` is `Servant.Links` + - `Servant.API.Internal.Test.ComprehensiveAPI` is `Servant.Test.ComprehensiveAPI` + +### Other changes + +- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204) + + For `Verb`s with response `Headers`, the implementation didn't check + for the content-type of the response. Now it does. + +- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241) + + Servant supports defining the same route multiple times with different + content-types and result-types, but servant-docs was only documenting + the first of copy of such duplicated routes. It now combines the + documentation from all the copies. + + Unfortunately, it is not yet possible for the documentation to specify + multiple status codes. + +- Add sponsorship button [#1190](https://github.com/haskell-servant/servant/pull/1190) + + [Well-Typed](https://www.well-typed.com/) is a consultancy which could help you with `servant` issues + (See consultancies section on https://www.servant.dev/). + +- Try changelog-d for changelog management [#1230](https://github.com/haskell-servant/servant/pull/1230) + + Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details + +- CI and testing tweaks. [#1154](https://github.com/haskell-servant/servant/pull/1154) [#1157](https://github.com/haskell-servant/servant/pull/1157) [#1182](https://github.com/haskell-servant/servant/pull/1182) [#1214](https://github.com/haskell-servant/servant/pull/1214) [#1229](https://github.com/haskell-servant/servant/pull/1229) [#1233](https://github.com/haskell-servant/servant/pull/1233) [#1242](https://github.com/haskell-servant/servant/pull/1242) [#1247](https://github.com/haskell-servant/servant/pull/1247) [#1250](https://github.com/haskell-servant/servant/pull/1250) [#1258](https://github.com/haskell-servant/servant/pull/1258) + + We are experiencing some bitrotting of cookbook recipe dependencies, + therefore some of them aren't build as part of our CI anymore. + +- New cookbook recipes [#1088](https://github.com/haskell-servant/servant/pull/1088) [#1171](https://github.com/haskell-servant/servant/pull/1171) [#1198](https://github.com/haskell-servant/servant/pull/1198) + + - [OIDC Recipe](#TODO) + - [MySQL Recipe](#TODO) + +- *servant-jsaddle* Progress on servant-jsaddle [#1216](https://github.com/haskell-servant/servant/pull/1216) +- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194) +- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197) +- *servant* Remove unused extensions from cabal file [#1201](https://github.com/haskell-servant/servant/pull/1201) +- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238) +- Dependency upgrades [#1173](https://github.com/haskell-servant/servant/pull/1173) [#1181](https://github.com/haskell-servant/servant/pull/1181) [#1183](https://github.com/haskell-servant/servant/pull/1183) [#1188](https://github.com/haskell-servant/servant/pull/1188) [#1224](https://github.com/haskell-servant/servant/pull/1224) [#1245](https://github.com/haskell-servant/servant/pull/1245) [#1257](https://github.com/haskell-servant/servant/pull/1257) +- Documentation updates [#1162](https://github.com/haskell-servant/servant/pull/1162) [#1174](https://github.com/haskell-servant/servant/pull/1174) [#1175](https://github.com/haskell-servant/servant/pull/1175) [#1234](https://github.com/haskell-servant/servant/pull/1234) [#1244](https://github.com/haskell-servant/servant/pull/1244) [#1247](https://github.com/haskell-servant/servant/pull/1247) + + +0.16.2 +------ + +* `singleton-bool-0.1.5` (`SBool` is re-exported) + - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+) + - Add `Show`, `Eq`, `Ord` `SBool b` instances. +* dependencies update + +0.16.1 +------ + +* Add `Semigroup` and `Monoid` `SourceT` instances + [#1158](https://github.com/haskell-servant/servant/pull/1158) + [#1159](https://github.com/haskell-servant/servant/pull/1159) +* Use `http-api-data-0.4.1` + [#1181](https://github.com/haskell-servant/servant/pull/1181) +* Allow newer dependencies + +0.16.0.1 +-------- + +- Make tests work with `http-media-0.8` + +0.16 +---- + +### Significant changes + +- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError` + [#1131](https://github.com/haskell-servant/servant/pull/1131) +- *servant-client-core* Rearrange modules. No more `Internal` modules, whole + API is versioned. + [#1130](https://github.com/haskell-servant/servant/pull/1130) +- *servant-http-streams* New package + [#1117](https://github.com/haskell-servant/servant/pull/1117) +- *servant-client-core* `RequestBody` is now + + ```haskell + = RequestBodyLBS LBS.ByteString + | RequestBodyBS BS.ByteString + | RequestBodySource (SourceIO LBS.ByteString) + ``` + + i.e. no more replicates `http-client`s API. + [#1117](https://github.com/haskell-servant/servant/pull/1117) + +- *servant-client-core* Keep structured exceptions in `ConnectionError` + constructor of `ClientError` + [#1115](https://github.com/haskell-servant/servant/pull/1115) + + ```diff + -| ConnectionError Text + +| ConnectionError SomeException + ``` + +- *servant-client-core* Preserve failing request in `FailureResponse` + constructor of `ClientError` + [#1114](https://github.com/haskell-servant/servant/pull/1114) + + ```diff + -FailureResponse Response + +-- | The server returned an error response including the + +-- failing request. 'requestPath' includes the 'BaseUrl' and the + +-- path of the request. + +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response + ``` + +- *servant-client* Fix (implement) `StreamBody` instance + [#1110](https://github.com/haskell-servant/servant/pull/1110) + +### Other changes + +- *servant-client* Update CookieJar with intermediate request/responses (redirects) + [#1104](https://github.com/haskell-servant/servant/pull/1104) +- *servant-server* Reorder HTTP failure code priorities + [#1103](https://github.com/haskell-servant/servant/pull/1103) +- *servant-server* Re-organise internal modules + [#1139](https://github.com/haskell-servant/servant/pull/1139) +- Allow `network-3.0` + [#1107](https://github.com/haskell-servant/servant/pull/1107) +- Add `NFData NoContent` instance + [#1090](https://github.com/haskell-servant/servant/pull/1090) + +- Documentation updates + [#1127](https://github.com/haskell-servant/servant/pull/1127) + [#1124](https://github.com/haskell-servant/servant/pull/1124) + [#1098](https://github.com/haskell-servant/servant/pull/1098) + +- CI updates + [#1123](https://github.com/haskell-servant/servant/pull/1123) + [#1121](https://github.com/haskell-servant/servant/pull/1121) + [#1119](https://github.com/haskell-servant/servant/pull/1119) + +0.15 +---- + +### Significant changes + +- Streaming refactoring. + [#991](https://github.com/haskell-servant/servant/pull/991) + [#1076](https://github.com/haskell-servant/servant/pull/1076) + [#1077](https://github.com/haskell-servant/servant/pull/1077) + + The streaming functionality (`Servant.API.Stream`) is refactored to use + `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), + which replaces both `StreamGenerator` and `ResultStream` types. + + New conversion type-classes are `ToSourceIO` and `FromSourceIO` + (replacing `ToStreamGenerator` and `BuildFromStream`). + There are instances for *conduit*, *pipes* and *machines* in new packages: + [servant-conduit](https://hackage.haskell.org/package/servant-conduit) + [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and + [servant-machines](https://hackage.haskell.org/package/servant-machines) + respectively. + + Writing new framing strategies is simpler. Check existing strategies for examples. + + This change shouldn't affect you, if you don't use streaming endpoints. + +- *servant-client* Separate streaming client. + [#1066](https://github.com/haskell-servant/servant/pull/1066) + + We now have two `http-client` based clients, + in `Servant.Client` and `Servant.Client.Streaming`. + + Their API is the same, except for + - `Servant.Client` **cannot** request `Stream` endpoints. + - `Servant.Client` is *run* by direct + `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)` + - `Servant.Client.Streaming` **can** request `Stream` endpoints. + - `Servant.Client.Streaming` is *used* by CPSised + `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b` + + To access `Stream` endpoints use `Servant.Client.Streaming` with + `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`. + You can use both too, `ClientEnv` and `BaseUrl` types are same for both. + + **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints. + Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until + the whole response is received. + + There is `Servant.Client.Streaming.runClientM` function, but it has + restricted type. `NFData a` constraint prevents using it with + `SourceT`, `Conduit` etc. response types. + + ```haskell + runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) + ``` + + This change shouldn't affect you, if you don't use streaming endpoints. + +- *servant-client-core* Related to the previous: + `streamingResponse` is removed from `RunClient`. + We have a new type-class: + + ```haskell + class RunClient m => RunStreamingClient m where + withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a + ``` + +- Drop support for GHC older than 8.0 + [#1008](https://github.com/haskell-servant/servant/pull/1008) + [#1009](https://github.com/haskell-servant/servant/pull/1009) + +- *servant* `ComprehensiveAPI` is a part of public API in `Servant.Test.ComprehensiveAPI` module. + This API type is used to verify that libraries implement all core combinators. + Now we won't change this type between major versions. + (This has been true for some time already). + [#1070](https://github.com/haskell-servant/servant/pull/1070) + +- *servant* Remove `Servant.Utils.Enter` module + (deprecated in `servant-0.12` in favour of `hoistServer`) + [#996](https://github.com/haskell-servant/servant/pull/996) + +- *servant-foreign* Add support so `HasForeign` can be implemented for + `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart) + [#1035](https://github.com/haskell-servant/servant/pull/1035) + +### Other changes + +- *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances. + [#1076](https://github.com/haskell-servant/servant/pull/1076) + +- *servant* NewlineFraming encodes newline after each element (i.e last) + [#1079](https://github.com/haskell-servant/servant/pull/1079) + [#1011](https://github.com/haskell-servant/servant/issues/1011) + +- *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a` + [#1064](https://github.com/haskell-servant/servant/pull/1064) + +- *servant-server* Add `MonadMask Handler` + [#1068](https://github.com/haskell-servant/servant/pull/1068) + +- *servant-docs* Fix markdown indentation + [#1043](https://github.com/haskell-servant/servant/pull/1043) + +- *servant* Export `GetHeaders'` + [#1052](https://github.com/haskell-servant/servant/pull/1052) + +- *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>` + [#1032](https://github.com/haskell-servant/servant/pull/1032) + +- *servant* Add `PutCreated` method type alias + [#1024](https://github.com/haskell-servant/servant/pull/1024) + +- *servant-client-core* Add `aeson` and `Lift BaseUrl` instances + [#1037](https://github.com/haskell-servant/servant/pull/1037) + +- *servant* Add `ToSourceIO (NonEmpty a)` instance + [#988](https://github.com/haskell-servant/servant/pull/988) + +- Development process improvements + - Apply `stylish-haskell` to all modules + [#1001](https://github.com/haskell-servant/servant/pull/1001) + - Amend `CONTRIBUTING.md` + [#1036](https://github.com/haskell-servant/servant/pull/1036) + - `servant-docs` has golden tests for `ComprehensiveAPI` + [#1071](https://github.com/haskell-servant/servant/pull/1071) + - Other + [#1039](https://github.com/haskell-servant/servant/pull/1039) + [#1046](https://github.com/haskell-servant/servant/pull/1046) + [#1062](https://github.com/haskell-servant/servant/pull/1062) + [#1069](https://github.com/haskell-servant/servant/pull/1069) + [#985](https://github.com/haskell-servant/servant/pull/985) + +- *Documentation* Tutorial and new recipes + - [Using free client](https://docs.servant.dev/en/latest/cookbook/using-free-client/UsingFreeClient.html) + [#1005](https://github.com/haskell-servant/servant/pull/1005) + - [Generating mock curl calls](https://docs.servant.dev/en/latest/cookbook/curl-mock/CurlMock.html) + [#1033](https://github.com/haskell-servant/servant/pull/1033) + - [Error logging with Sentry](https://docs.servant.dev/en/latest/cookbook/sentry/Sentry.html) + [#987](https://github.com/haskell-servant/servant/pull/987) + - [Hoist Server With Context for Custom Monads](https://docs.servant.dev/en/latest/cookbook/hoist-server-with-context/HoistServerWithContext.html) + [#1044](https://github.com/haskell-servant/servant/pull/1044) + - [How To Test Servant Applications](https://docs.servant.dev/en/latest/cookbook/testing/Testing.html) + [#1050](https://github.com/haskell-servant/servant/pull/1050) + - `genericServeT`: using custom monad with `Servant.API.Generic` + in [Using generics](https://docs.servant.dev/en/latest/cookbook/generic/Generic.html) + [#1058](https://github.com/haskell-servant/servant/pull/1058) + - Tutorial + [#974](https://github.com/haskell-servant/servant/pull/974) + [#1007](https://github.com/haskell-servant/servant/pull/1007) + - miscellanea: fixed typos etc. + [#1030](https://github.com/haskell-servant/servant/pull/1030) + [#1020](https://github.com/haskell-servant/servant/pull/1020) + [#1059](https://github.com/haskell-servant/servant/pull/1059) + +- *Documentation* README + [#1010](https://github.com/haskell-servant/servant/pull/1010) + +- *servant-client-ghcjs* updates. **note** package is not released on Hackage + [#938](https://github.com/haskell-servant/servant/pull/938) + +0.14.1 +------ + +- Merge in (and slightly refactor) `servant-generic` + (by [Patrick Chilton](https://github.com/chpatrick)) + into `servant` (`Servant.API.Generic`), + `servant-client-code` (`Servant.Client.Generic`) + and `servant-server` (`Servant.Server.Generic`). + +- Deprecate `Servant.Utils.Links`, use `Servant.Links`. + [#998](https://github.com/haskell-servant/servant/pull/998) + +- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`. + +0.14 +---- + +### Significant changes + +- `Stream` takes a status code argument + + ```diff + -Stream method framing ctype a + +Stream method status framing ctype a + ``` + + ([#966](https://github.com/haskell-servant/servant/pull/966) + [#972](https://github.com/haskell-servant/servant/pull/972)) + +- `ToStreamGenerator` definition changed, so it's possible to write an instance + for conduits. + + ```diff + -class ToStreamGenerator f a where + - toStreamGenerator :: f a -> StreamGenerator a + +class ToStreamGenerator a b | a -> b where + + toStreamGenerator :: a -> StreamGenerator b + ``` + + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- Added `NoFraming` streaming strategy + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- *servant-client-core* Free `Client` implementation. + Useful for testing `HasClient` instances. + ([#920](https://github.com/haskell-servant/servant/pull/920)) + +- *servant-client-core* Add `hoistClient` to `HasClient`. + Just like `hoistServer` allows us to change the monad in which request handlers + of a web application live, we also have `hoistClient` for changing the monad + in which *client functions* live. + Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). + ([#936](https://github.com/haskell-servant/servant/pull/936)) + + iF you have own combinators, you'll need to define a new method of + `HasClient` class, for example: + + ```haskell + type Client m (MyCombinator :> api) = MyValue :> Client m api + hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl + ``` + +- *servant* Add `safeLink' :: (Link -> a) -> ... -> MkLink endpoint a`, + which allows to create helpers returning something else than `Link`. + ([#968](https://github.com/haskell-servant/servant/pull/968)) + +- *servant-server* File serving in polymorphic monad. + i.e. Generalised types of `serveDirectoryFileServer` etc functions in + `Servant.Utils.StaticFiles` + ([#953](https://github.com/haskell-servant/servant/pull/953)) + +- *servant-server* `ReqBody` content type check is recoverable. + This allows writing APIs like: + + ```haskell + ReqBody '[JSON] Int :> Post '[PlainText] Int + :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int + ``` + + which is useful when handlers are subtly different, + for example may do less work. + ([#937](https://github.com/haskell-servant/servant/pull/937)) + +- *servant-client* Add more constructors to `RequestBody`, including + `RequestBodyStream`. + *Note:* we are looking for http-library agnostic API, + so the might change again soon. + Tell us which constructors are useful for you! + ([#913](https://github.com/haskell-servant/servant/pull/913)) + +### Other changes + +- `GetHeaders` instances implemented without `OverlappingInstances` + ([#971](https://github.com/haskell-servant/servant/pull/971)) + +- Added tests or enabled tests + ([#975](https://github.com/haskell-servant/servant/pull/975)) + +- Add [pagination cookbook recipe](https://docs.servant.dev/en/release-0.14/cookbook/pagination/Pagination.html) + ([#946](https://github.com/haskell-servant/servant/pull/946)) + +- Add [`servant-flatten` "spice" to the structuring api recipe](https://docs.servant.dev/en/release-0.14/cookbook/structuring-apis/StructuringApis.html) + ([#929](https://github.com/haskell-servant/servant/pull/929)) + +- Dependency updates + ([#900](https://github.com/haskell-servant/servant/pull/900) + [#919](https://github.com/haskell-servant/servant/pull/919) + [#924](https://github.com/haskell-servant/servant/pull/924) + [#943](https://github.com/haskell-servant/servant/pull/943) + [#964](https://github.com/haskell-servant/servant/pull/964) + [#967](https://github.com/haskell-servant/servant/pull/967) + [#976](https://github.com/haskell-servant/servant/pull/976)) + +- Documentation updates + [#963](https://github.com/haskell-servant/servant/pull/963) + [#960](https://github.com/haskell-servant/servant/pull/960) + [#908](https://github.com/haskell-servant/servant/pull/908) + [#958](https://github.com/haskell-servant/servant/pull/958) + [#948](https://github.com/haskell-servant/servant/pull/948) + [#928](https://github.com/haskell-servant/servant/pull/928) + [#921](https://github.com/haskell-servant/servant/pull/921)) + +- Development process improvements + ([#680](https://github.com/haskell-servant/servant/pull/680) + [#917](https://github.com/haskell-servant/servant/pull/917) + [#923](https://github.com/haskell-servant/servant/pull/923) + [#961](https://github.com/haskell-servant/servant/pull/961) + [#973](https://github.com/haskell-servant/servant/pull/973)) + +### Note + +(VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant\/pull\/\1)/` + +0.13.0.1 +-------- + +- Support `base-compat-0.10` + +0.13 +---- + +### Significant changes + +- Streaming endpoint support. + ([#836](https://github.com/haskell-servant/servant/pull/836)) + + ```haskell + type StreamApi f = "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) + ``` + + See tutorial for more details + - [A web API as a type - StreamGet and StreamPost](http://docs.servant.dev/en/release-0.13/tutorial/ApiType.html#streamget-and-streampost) + - [Serving an API - streaming endpoints](http://docs.servant.dev/en/release-0.13/tutorial/Server.html#streaming-endpoints) + - [Querying an API - Querying Streaming APIs](http://docs.servant.dev/en/release-0.13/tutorial/Client.html#querying-streaming-apis) + +- *servant* Add `Servant.API.Modifiers` + ([#873](https://github.com/haskell-servant/servant/pull/873) + [#903](https://github.com/haskell-servant/servant/pull/903)) + + `QueryParam`, `Header` and `ReqBody` understand modifiers: + - `Required` or `Optional` (resulting in `a` or `Maybe a` in handlers) + - `Strict` or `Lenient` (resulting in `a` or `Either String a` in handlers) + + Also you can use `Description` as a modifier, but it doesn't yet work + with `servant-docs`, only `servant-swagger`. [There is an issue.](https://github.com/haskell-servant/servant/issues/902) + +- *servant-client* Support `http-client`’s `CookieJar` + ([#897](https://github.com/haskell-servant/servant/pull/897) + [#883](https://github.com/haskell-servant/servant/pull/883)) + + `ClientM` preserves cookies between requests, + if given initial `CookieJar`. + To migrate from older code, change `ClientEnv` constructor + to `mkClientEnv` which makes `ClientEnv` without `CookieJar`. + +- *servant* Mono-kind-ise modifiers, resulting in better error messages. + ([#887](https://github.com/haskell-servant/servant/issues/887) + [#890](https://github.com/haskell-servant/servant/pull/890)) + +- *servant* Add `TypeError ... => HasServer`s instances in GHC-8.2 for + not saturated modifiers (`Capture "foo" :> ...`) or `->` in place of `:>`. + ([#893](https://github.com/haskell-servant/servant/pull/893)) + +- *Cookbook* example projects at + http://docs.servant.dev/en/master/cookbook/index.html + ([#867](https://github.com/haskell-servant/servant/pull/867) + [#892](https://github.com/haskell-servant/servant/pull/882)) + +- *Experimental work* `servant-client-ghcjs` + ([#818](https://github.com/haskell-servant/servant/pull/818) + [#869](https://github.com/haskell-servant/servant/pull/869)) + +### Other changes + +- *servant* Links aren't double escaped + ([#878](https://github.com/haskell-servant/servant/pull/878)) + +- Dependency updates + ([#900](https://github.com/haskell-servant/servant/pull/900) + [#898](https://github.com/haskell-servant/servant/pull/898) + [#895](https://github.com/haskell-servant/servant/pull/895) + [#872](https://github.com/haskell-servant/servant/pull/872)) + +- Documentation updates + ([#875](https://github.com/haskell-servant/servant/pull/875) + [#861](https://github.com/haskell-servant/servant/pull/861)) + +- Refactorings + ([#899](https://github.com/haskell-servant/servant/pull/899) + [#896](https://github.com/haskell-servant/servant/pull/896) + [#889](https://github.com/haskell-servant/servant/pull/889) + [#891](https://github.com/haskell-servant/servant/pull/891) + [#892](https://github.com/haskell-servant/servant/pull/892) + [#885](https://github.com/haskell-servant/servant/pull/885)) + +0.12.1 +------ + +### Bug fixes + +- Prevent double-escaping in link segments + ([#835](https://github.com/haskell-servant/servant/issues/835) + [#878](https://github.com/haskell-servant/servant/pull/878)) + +0.12 +--- + +### Significant changes + +- *servant-client* *servant-client-core* + Factored out of `servant-client` all the functionality that was + independent of the `http-client` backend. + ([#803](https://github.com/haskell-servant/servant/pull/803) + [#821](https://github.com/haskell-servant/servant/issues/821)) + + If you have own combinators, you'll need to add an additional `m` argument + in `HasClient`, `Client` and `clientWithRoute`: + + ```diff + -class HasClient api + - type Client (api :: *) :: * + - clientWithRoute :: Proxy api -> Req -> Client api + +class HasClient m api + + type Client (m :: * -> *) (api :: *) :: * + + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api + ``` + + See https://github.com/haskell-servant/servant-auth/pull/67/commits/f777818e3cc0fa3ed2346baff8328e96d62b1790 for a real world example. + +- *servant-server* Added `hoistServer` member to the `HasServer` class, which is `HasServer` + specific `enter`. + ([#804](https://github.com/haskell-servant/servant/pull/804) + [#824](https://github.com/haskell-servant/servant/pull/824)) + + `enter` isn't exported from `Servant` module anymore. You can change + `enter` to `hoistServer` in a straight forward way. + Unwrap natural transformation and add an api type `Proxy`: + + ```diff + -server = enter (NT nt) impl + +server = hoistServer (Proxy :: Proxy MyApi) nt impl + ``` + + If you have own combinators, you'll need to define a new method of + `HasServer` class, for example: + + ```haskell + type ServerT (MyCombinator :> api) m = MyValue -> ServerT api m + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + ``` + + See https://github.com/haskell-servant/servant-auth/pull/67/commits/8ee3b6315247ac076516213fd7cfcdbfdb583ac9 for a real world example. + +- Add `Description` and `Summary` combinators + ([#767](https://github.com/haskell-servant/servant/pull/767)) + + It's possible to annotate endpoints with free form text. + This information is used by e.g. by `servant-swagger`, see screenshot in + https://github.com/phadej/servant-swagger-ui + +- Lower `:>` and `:<|>` infix precedence to 4 and 3 respectively + ([#761](https://github.com/haskell-servant/servant/issues/761)) + + This shouldn't affect you, except if you define your own infix operators + for Servant type-level DSL. + +### Other changes + +- *servant-foreign* Derive `Data` for all types + ([#809](https://github.com/haskell-servant/servant/pull/809)) +- *servant-docs* Add authentication lenses + ([#787](https://github.com/haskell-servant/servant/pull/787)) +- *servant-docs* Generated markdown improvements + ([#813](https://github.com/haskell-servant/servant/pull/787) + [#767](https://github.com/haskell-servant/servant/pull/767) + [#790](https://github.com/haskell-servant/servant/pull/790) + [#788](https://github.com/haskell-servant/servant/pull/788)) +- Add `addLinks` to generate all links for unnested APIs. + ([#851](https://github.com/haskell-servant/servant/pull/851)) +- Allow newest dependencies + ([#772](https://github.com/haskell-servant/servant/pull/772) + [#842](https://github.com/haskell-servant/servant/pull/842)) +- Documentation improvements and typo fixes + ([#757](https://github.com/haskell-servant/servant/pull/757) + [#771](https://github.com/haskell-servant/servant/pull/771) + [#775](https://github.com/haskell-servant/servant/pull/775) + [#790](https://github.com/haskell-servant/servant/pull/790) + [#791](https://github.com/haskell-servant/servant/pull/791) + [#806](https://github.com/haskell-servant/servant/pull/806)) +- Development process improvements + ([#764](https://github.com/haskell-servant/servant/pull/764) + [#839](https://github.com/haskell-servant/servant/pull/839)) + +0.11 +---- + +### Breaking changes + +- `Enter` refactored + ([#734](https://github.com/haskell-servant/servant/issues/734) + , [#736](https://github.com/haskell-servant/servant/pull/736)) + +### Other changes + +- Add a type representing an empty API + ([#753](https://github.com/haskell-servant/servant/pull/753)) +- Add `linkURI'` and `Link` accessors + ([#745](https://github.com/haskell-servant/servant/pull/745) + , [#717](https://github.com/haskell-servant/servant/pull/717) + , [#715](https://github.com/haskell-servant/servant/issues/715)) +- Prepare for GHC-8.2 + ([#722](https://github.com/haskell-servant/servant/pull/722)) +- Add `HasLink AuthProtect` instance + ([#720](https://github.com/haskell-servant/servant/pull/720)) +- `AllCTRender [] ()` `TypeError` (use `NoContent`) + ([#671](https://github.com/haskell-servant/servant/pull/671)) +- Documentation improvements and typo fixes + ([#702](https://github.com/haskell-servant/servant/pull/702) + , [#709](https://github.com/haskell-servant/servant/pull/709) + , [#716](https://github.com/haskell-servant/servant/pull/716) + , [#725](https://github.com/haskell-servant/servant/pull/725) + , [#727](https://github.com/haskell-servant/servant/pull/727)) + +0.10 +---- + +### Breaking changes + +* Use `NT` from `natural-transformation` for `Enter` + ([#616](https://github.com/haskell-servant/servant/issues/616)) + +* Change to `MkLink (Verb ...) = Link` (previously `URI`). To consume `Link` + use its `ToHttpApiData` instance or `linkURI`. + ([#527](https://github.com/haskell-servant/servant/issues/527)) + +### Other changes + +* Add `Servant.API.TypeLevel` module with type families to work with API types. + ([#345](https://github.com/haskell-servant/servant/pull/345) + , [#305](https://github.com/haskell-servant/servant/issues/305)) + +* Default JSON content type change to `application/json;charset=utf-8`. + ([#263](https://github.com/haskell-servant/servant/issues/263)) + Related browser bugs: + [Chromium](https://bugs.chromium.org/p/chromium/issues/detail?id=438464) and + [Firefox](https://bugzilla.mozilla.org/show_bug.cgi?id=918742) + +* `Accept` class may accept multiple content-types. `MimeUnrender` adopted as well. + ([#613](https://github.com/haskell-servant/servant/pull/614) + , [#615](https://github.com/haskell-servant/servant/pull/615)) + +0.9.1 +------ + +* Added 'noHeader' function for *not* adding response headers. + +0.9 +--- + +* Added Eq, Show, Read, Generic and Ord instances to IsSecure +* BACKWARDS INCOMPATIBLE: replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo` +* BACKWARDS INCOMPATIBLE: Moved `From/ToFormUrlEncoded` classes, which were renamed to `From/ToForm` to `http-api-data` + +0.8.1 +---- + +* Add `CaptureAll` combinator. Captures all of the remaining segments in a URL. +* Add `Servant.API.TypeLevel` module, with frequently used type-level +functionaliy. + +0.8 +--- + +* Minor fixes, documentation changes and cabal tweaks + 0.7.1 ----- 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/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,130 +1,197 @@ -name: servant -version: 0.7.1 -synopsis: A family of combinators for defining webservices APIs +cabal-version: 3.0 +name: servant +version: 0.20.3.0 +synopsis: A family of combinators for defining webservices APIs +category: Servant, Web description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + 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: Web -build-type: Simple -cabal-version: >=1.10 -tested-with: GHC >= 7.8 -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 +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 Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes + Servant.API.Description + Servant.API.Empty Servant.API.Experimental.Auth + Servant.API.Fragment + Servant.API.Generic Servant.API.Header + Servant.API.Host Servant.API.HttpVersion - Servant.API.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.10 - , base-compat >= 0.9 - , aeson >= 0.7 - , attoparsec >= 0.12 - , bytestring == 0.10.* - , bytestring-conversion == 0.3.* - , case-insensitive >= 1.2 - , http-api-data >= 0.1 && < 0.3 - , http-media >= 0.4 && < 0.7 - , http-types >= 0.8 && < 0.10 - , mtl >= 2 && < 3 - , mmorph >= 1 - , text >= 1 && < 2 - , string-conversions >= 0.3 && < 0.5 - , network-uri >= 2.6 - , vault >= 0.3 && <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 + , base >= 4.16.4.0 && <4.22 + , bytestring >=0.11 && <0.13 + , constraints >=0.2 + , containers >=0.6.5.1 && <0.9 + , mtl ^>=2.2.2 || ^>=2.3.1 + , sop-core >=0.4.0.0 && <0.6 + , generics-sop ^>=0.5.1 + , text >=1.2.3.0 && <2.2 + , transformers >=0.5.2.0 && <0.7 + -- We depend (heavily) on the API of these packages: + -- i.e. re-export, or allow using without direct dependency + build-depends: + , http-api-data >=0.4.1 && <0.7 + , singleton-bool >=0.1.4 && <0.2 + + -- Other dependencies: Lower bound around what is in the latest Stackage LTS. + -- Here can be exceptions if we really need features from the newer versions. + build-depends: + , aeson >=1.4.1.0 && <2.3 + , attoparsec >=0.13.2.2 && <0.15 + , bifunctors >=5.5.3 && <5.7 + , case-insensitive >=1.2.0.11 && <1.3 + , deepseq >=1.4.2.0 && <1.6 + , http-media >=0.7.1.3 && <0.9 + , http-types >=0.12.2 && <0.13 + , mmorph >=1.1.2 && <1.3 + , network-uri >=2.6.1.0 && <2.7 + , QuickCheck >=2.12.6.1 && <2.16 + , vault >=0.3.1.2 && <0.4 + + hs-source-dirs: src + test-suite spec - 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.API.ContentTypesSpec + Servant.API.ResponseHeadersSpec + Servant.API.StreamSpec + Servant.LinksSpec + + -- Dependencies inherited from the library. No need to specify bounds. build-depends: - base == 4.* , aeson - , attoparsec + , base , bytestring - , hspec == 2.* - , QuickCheck - , quickcheck-instances + , http-media + , mtl + , network-uri , servant - , string-conversions , text - , url -test-suite doctests - build-depends: base - , servant - , doctest - , filemanip - , directory - , filepath - type: exitcode-stdio-1.0 - main-is: test/Doctests.hs - buildable: True - default-language: Haskell2010 - ghc-options: -Wall -threaded - include-dirs: include + -- Additional dependencies + build-depends: + , hspec >=2.6.0 && <2.12 + , QuickCheck >=2.12.6.1 && <2.16 + , quickcheck-instances >=0.3.19 && <0.4 + + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 diff --git a/src/Servant/API.hs b/src/Servant/API.hs --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -5,16 +5,26 @@ -- | Type-level combinator for expressing subrouting: @':>'@ module Servant.API.Alternative, -- | Type-level combinator for alternative endpoints: @':<|>'@ + module Servant.API.Empty, + -- | Type-level combinator for an empty API: @'EmptyAPI'@ + module Servant.API.Modifiers, + -- | Type-level modifiers for 'QueryParam', 'Header' and 'ReqBody'. -- * Accessing information from the request module Servant.API.Capture, - -- | Capturing parts of the url path as parsed values: @'Capture'@ + -- | 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, @@ -25,13 +35,29 @@ -- | Access the location for arbitrary data to be shared by applications and middleware module Servant.API.WithNamedContext, -- | Access context entries in combinators in servant-server + module Servant.API.WithResource, + -- | Access a managed resource scoped to a single request -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, + module Servant.API.UVerb, + -- * Sub-APIs defined as records of routes + module Servant.API.NamedRoutes, + module Servant.API.Generic, + + -- * Streaming endpoints, distinguished by HTTP method + module Servant.API.Stream, + + -- * Server-sent events (SSE) + module Servant.API.ServerSentEvents, + -- * Authentication module Servant.API.BasicAuth, + -- * Endpoints description + module Servant.API.Description, + -- * Content Types module Servant.API.ContentTypes, -- | Serializing and deserializing types based on @Accept@ and @@ -53,55 +79,95 @@ module Servant.API.Experimental.Auth, -- | General Authentication - -- * Utilities - module Servant.Utils.Links, + -- * Links + module Servant.Links, -- | Type-safe internal URIs + + -- * Re-exports + If, + SBool (..), SBoolI (..) ) where -import Servant.API.Alternative ((:<|>) (..)) -import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) -import Servant.API.Capture (Capture) -import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, - FromFormUrlEncoded (..), JSON, - MimeRender (..), NoContent (NoContent), - MimeUnrender (..), OctetStream, - PlainText, ToFormUrlEncoded (..)) -import Servant.API.Experimental.Auth (AuthProtect) -import Servant.API.Header (Header (..)) -import Servant.API.HttpVersion (HttpVersion (..)) -import Servant.API.IsSecure (IsSecure (..)) -import Servant.API.QueryParam (QueryFlag, QueryParam, - QueryParams) -import Servant.API.Raw (Raw) -import Servant.API.RemoteHost (RemoteHost) -import Servant.API.ReqBody (ReqBody) -import Servant.API.ResponseHeaders (AddHeader (addHeader), - BuildHeadersTo (buildHeadersTo), - GetHeaders (getHeaders), - HList (..), Headers (..), - getHeadersHList, getResponse) -import Servant.API.Sub ((:>)) -import Servant.API.Vault (Vault) -import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, - DeleteNoContent, - DeleteNonAuthoritative, Get, - GetAccepted, GetNoContent, - GetNonAuthoritative, - GetPartialContent, - GetResetContent, - Patch, - PatchAccepted, PatchNoContent, - PatchNoContent, - PatchNonAuthoritative, Post, - PostAccepted, PostNoContent, - PostNonAuthoritative, - PostResetContent, Put, - PutAccepted, PutNoContent, - PutNoContent, PutNonAuthoritative, - ReflectMethod (reflectMethod), - Verb, StdMethod(..)) -import Servant.API.WithNamedContext (WithNamedContext) -import Servant.Utils.Links (HasLink (..), IsElem, IsElem', - URI (..), safeLink) -import Web.HttpApiData (FromHttpApiData (..), - ToHttpApiData (..)) +import Data.Singletons.Bool + (SBool (..), SBoolI (..)) +import Data.Type.Bool + (If) +import Servant.API.Alternative + ((:<|>) (..)) +import Servant.API.BasicAuth + (BasicAuth, BasicAuthData (..)) +import Servant.API.Capture + (Capture, Capture', CaptureAll) +import Servant.API.ContentTypes + (Accept (..), FormUrlEncoded, JSON, MimeRender (..), + MimeUnrender (..), NoContent (NoContent), OctetStream, + PlainText) +import Servant.API.Description + (Description, Summary) +import Servant.API.Empty + (EmptyAPI (..)) +import Servant.API.Experimental.Auth + (AuthProtect) +import Servant.API.Fragment + (Fragment) +import Servant.API.Generic + (AsApi, GServantProduct, GenericMode ((:-)), GenericServant, + ToServant, ToServantApi, fromServant, genericApi, toServant) +import Servant.API.Header + (Header, Header') +import Servant.API.Host (Host) +import Servant.API.HttpVersion + (HttpVersion (..)) +import Servant.API.IsSecure + (IsSecure (..)) +import Servant.API.Modifiers + (Lenient, Optional, Required, Strict) +import Servant.API.NamedRoutes + (NamedRoutes) +import Servant.API.QueryParam + (QueryFlag, QueryParam, QueryParam', QueryParams) +import Servant.API.QueryString + (QueryString, DeepQuery) +import Servant.API.Raw + (Raw, RawM) +import Servant.API.RemoteHost + (RemoteHost) +import Servant.API.ReqBody + (ReqBody, ReqBody') +import Servant.API.ResponseHeaders + (AddHeader, BuildHeadersTo (buildHeadersTo), + GetHeaders (getHeaders), HList (..), HasResponseHeader, + Headers (..), ResponseHeader (..), addHeader, addHeader', + getHeadersHList, getResponse, lookupResponseHeader, noHeader, + noHeader') +import Servant.API.ServerSentEvents + (EventKind (..), ServerSentEvents, ServerSentEvents') +import Servant.API.Stream + (FramingRender (..), FramingUnrender (..), FromSourceIO (..), + NetstringFraming, NewlineFraming, NoFraming, SourceIO, Stream, + StreamBody, StreamBody', StreamGet, StreamPost, + ToSourceIO (..)) +import Servant.API.Sub + ((:>)) +import Servant.API.UVerb + (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union, + Unique, WithStatus (..), inject, statusOf) +import Servant.API.Vault + (Vault) +import Servant.API.Verbs + (Delete, DeleteAccepted, DeleteNoContent, + DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, + GetNonAuthoritative, GetPartialContent, GetResetContent, + NoContentVerb, Patch, PatchAccepted, PatchNoContent, + PatchNonAuthoritative, Post, PostAccepted, PostCreated, + PostNoContent, PostNonAuthoritative, PostResetContent, Put, + PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative, + ReflectMethod (reflectMethod), StdMethod (..), Verb) +import Servant.API.WithNamedContext + (WithNamedContext) +import Servant.API.WithResource + (WithResource) +import Servant.Links + (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) +import Web.HttpApiData + (FromHttpApiData (..), ToHttpApiData (..)) 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,17 +1,22 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE DeriveFoldable #-} -#endif {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where -import Data.Typeable (Typeable) -import Prelude () -import Prelude.Compat +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Data.Biapplicative + (Biapplicative (..)) +import Data.Bifoldable + (Bifoldable (..)) +import Data.Bifunctor + (Bifunctor (..)) +import Data.Bitraversable + (Bitraversable (..)) +import Data.Typeable + (Typeable) -- | Union of two APIs, first takes precedence in case of overlap. -- @@ -22,12 +27,27 @@ -- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books -- :} data a :<|> b = a :<|> b - deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) -infixr 8 :<|> + deriving stock (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) +infixr 3 :<|> +instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where + (a :<|> b) <> (a' :<|> b') = (a <> a') :<|> (b <> b') + instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty - (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,13 +1,18 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PolyKinds #-} + module Servant.API.BasicAuth where -import Data.ByteString (ByteString) -import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import Data.ByteString + (ByteString) +import Data.Kind + (Type) +import Data.Typeable + (Typeable) +import GHC.TypeLits + (Symbol) -- | Combinator for . @@ -21,7 +26,7 @@ -- In Basic Auth, username and password are base64-encoded and transmitted via -- the @Authorization@ header. Handshakes are not required, making it -- relatively efficient. -data BasicAuth (realm :: Symbol) (userData :: *) +data BasicAuth (realm :: Symbol) (userData :: Type) deriving (Typeable) -- | A simple datatype to hold data required to decorate a request 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 @@ -2,22 +2,41 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Capture (Capture) where +module Servant.API.Capture (Capture, Capture', CaptureAll) where -import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import Data.Kind + (Type) +import Data.Typeable + (Typeable) +import GHC.TypeLits + (Symbol) -- | Capture a value from the request path under a certain type @a@. -- -- Example: -- -- >>> -- GET /books/:isbn -- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -data Capture (sym :: Symbol) a +type Capture = Capture' '[] -- todo + +-- | 'Capture' which can be modified. For example with 'Description'. +data Capture' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving (Typeable) +-- | Capture all remaining values from the request path under a certain type +-- @a@. +-- +-- Example: +-- +-- >>> -- GET /src/* +-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile +data CaptureAll (sym :: Symbol) (a :: Type) + deriving (Typeable) + -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } +-- >>> data SourceFile +-- >>> instance ToJSON SourceFile where { toJSON = undefined } 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,20 +1,19 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -#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 @@ -22,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, @@ -50,6 +49,7 @@ , PlainText , FormUrlEncoded , OctetStream + , EventStream -- * Building your own Content-Type , Accept(..) @@ -66,44 +66,45 @@ , AllMime(..) , AllMimeRender(..) , AllMimeUnrender(..) - , FromFormUrlEncoded(..) - , ToFormUrlEncoded(..) , eitherDecodeLenient , canHandleAcceptH + , EventStreamChunk(..) ) where -import Control.Arrow (left) -import Control.Monad.Compat -import Data.Aeson (FromJSON(..), ToJSON(..), encode) -import Data.Aeson.Parser (value) -import Data.Aeson.Types (parseEither) -import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, - skipSpace, ()) +import Control.Arrow + (left) +import Control.DeepSeq + (NFData) +import Data.Aeson + (FromJSON (..), ToJSON (..), encode, eitherDecode) +import Data.Bifunctor + (bimap) import qualified Data.ByteString as BS -import Data.ByteString.Lazy (ByteString, fromStrict, - toStrict) -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy.Char8 as BC -import Data.Maybe (isJust) -import Data.Monoid.Compat -import Data.String.Conversions (cs) +import Data.ByteString.Lazy + (ByteString, fromStrict, toStrict) +import Data.Kind + (Type) +import qualified Data.List.NonEmpty as NE +import Data.Maybe + (isJust) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable -import GHC.Generics (Generic) +import GHC.Generics + (Generic) +import qualified GHC.TypeLits as TL import qualified Network.HTTP.Media as M -import Network.URI (escapeURIString, - isUnreserved, unEscapeString) -import Prelude () -import Prelude.Compat +import Web.FormUrlEncoded + (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) -- * Provided content types data JSON deriving Typeable data PlainText deriving Typeable data FormUrlEncoded deriving Typeable data OctetStream deriving Typeable +data EventStream deriving Typeable -- * Accept class @@ -122,10 +123,18 @@ -- class Accept ctype where contentType :: Proxy ctype -> M.MediaType + contentType = NE.head . contentTypes + contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType + contentTypes = (NE.:| []) . contentType + + {-# MINIMAL contentType | contentTypes #-} + -- | @application/json@ instance Accept JSON where - contentType _ = "application" M.// "json" + contentTypes _ = + "application" M.// "json" M./: ("charset", "utf-8") NE.:| + [ "application" M.// "json" ] -- | @application/x-www-form-urlencoded@ instance Accept FormUrlEncoded where @@ -139,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) @@ -154,7 +167,7 @@ -- > instance Accept MyContentType where -- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") -- > --- > instance Show a => MimeRender MyContentType where +-- > instance Show a => MimeRender MyContentType a where -- > mimeRender _ val = pack ("This is MINE! " ++ show val) -- > -- > type MyAPI = "path" :> Get '[MyContentType] Int @@ -162,19 +175,23 @@ 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 +instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") + => AllCTRender '[] () where + handleAcceptH _ _ _ = error "unreachable" + -------------------------------------------------------------------------- -- * Unrender @@ -201,30 +218,47 @@ -- class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a + mimeUnrender p = mimeUnrenderWithType p (contentType p) -class AllCTUnrender (list :: [*]) a where + -- | Variant which is given the actual 'M.MediaType' provided by the other party. + -- + -- In the most cases you don't want to branch based on the 'M.MediaType'. + -- See for a motivating example. + mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a + mimeUnrenderWithType p _ = mimeUnrender p + + {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} + +class AllCTUnrender (list :: [Type]) a where + canHandleCTypeH + :: Proxy list + -> ByteString -- Content-Type header + -> Maybe (ByteString -> Either String a) + handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) + handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where - handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) - where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body + canHandleCTypeH p 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 allMime _ = [] instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where - allMime _ = (contentType pctyp):allMime pctyps - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps + allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps + where + pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h @@ -232,70 +266,78 @@ -------------------------------------------------------------------------- -- 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 - allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)] - where pctyp = Proxy :: Proxy ctyp +instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where + allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp + where + bs = mimeRender pctyp a + pctyp = Proxy :: Proxy ctyp -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where - allMimeRender _ a = (contentType pctyp, mimeRender pctyp a) - :(allMimeRender pctyps a) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy (ctyp' ': ctyps) + allMimeRender _ a = + map (, bs) (NE.toList $ contentTypes pctyp) + ++ allMimeRender pctyps a + where + bs = mimeRender pctyp a + pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy (ctyp' ': ctyps) -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and -- then this would be taken care of. However there is no more specific instance -- between that and 'MimeRender JSON a', so we do this instead -instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where - allMimeRender _ _ = [(contentType pctyp, "")] - where pctyp = Proxy :: Proxy ctyp +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 - -> ByteString - -> [(M.MediaType, Either String a)] + -> [(M.MediaType, ByteString -> Either String a)] instance AllMimeUnrender '[] a where - allMimeUnrender _ _ = [] + allMimeUnrender _ = [] instance ( MimeUnrender ctyp a , AllMimeUnrender ctyps a ) => AllMimeUnrender (ctyp ': ctyps) a where - allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val) - :(allMimeUnrender pctyps val) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps + allMimeUnrender _ = + map mk (NE.toList $ contentTypes pctyp) + ++ allMimeUnrender pctyps + where + mk ct = (ct, mimeUnrenderWithType pctyp ct) + pctyp = Proxy :: Proxy ctyp + pctyps = Proxy :: Proxy ctyps -------------------------------------------------------------------------- -- * MimeRender Instances -- | `encode` -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where mimeRender _ = encode --- | @encodeFormUrlEncoded . toFormUrlEncoded@ +-- | @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_ - ToFormUrlEncoded a => MimeRender FormUrlEncoded a where - mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded +instance {-# OVERLAPPABLE #-} + ToForm a => MimeRender FormUrlEncoded a where + mimeRender _ = urlEncodeAsForm -- | `TextL.encodeUtf8` instance MimeRender PlainText TextL.Text where @@ -307,7 +349,7 @@ -- | @BC.pack@ instance MimeRender PlainText String where - mimeRender _ = BC.pack + mimeRender _ = TextL.encodeUtf8 . TextL.pack -- | @id@ instance MimeRender OctetStream ByteString where @@ -319,40 +361,29 @@ -- | A type for responses without content-body. data NoContent = NoContent - deriving (Show, Eq, Read) + 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 --- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@ +-- | @urlDecodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) -instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where - mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded +instance FromForm a => MimeUnrender FormUrlEncoded a where + mimeUnrender _ = left TextS.unpack . urlDecodeAsForm -- | @left show . TextL.decodeUtf8'@ instance MimeUnrender PlainText TextL.Text where @@ -364,62 +395,27 @@ -- | @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 - --------------------------------------------------------------------------- --- * FormUrlEncoded - --- | A type that can be converted to @application/x-www-form-urlencoded@ -class ToFormUrlEncoded a where - toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)] - -instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where - toFormUrlEncoded = id - --- | A type that can be converted from @application/x-www-form-urlencoded@, --- with the possibility of failure. -class FromFormUrlEncoded a where - fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a - -instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where - fromFormUrlEncoded = return - -encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString -encodeFormUrlEncoded xs = - let escape :: TextS.Text -> ByteString - escape = cs . escapeURIString isUnreserved . cs - encodePair :: (TextS.Text, TextS.Text) -> ByteString - encodePair (k, "") = escape k - encodePair (k, v) = escape k <> "=" <> escape v - in B.intercalate "&" $ map encodePair xs +-- | Chunk of an event stream +newtype EventStreamChunk = EventStreamChunk + { unEventStreamChunk :: ByteString } -decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)] -decodeFormUrlEncoded "" = return [] -decodeFormUrlEncoded q = do - let xs :: [TextS.Text] - xs = TextS.splitOn "&" . cs $ q - parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text) - parsePair p = - case TextS.splitOn "=" p of - [k,v] -> return ( unescape k - , unescape v - ) - [k] -> return ( unescape k, "" ) - _ -> Left $ "not a valid pair: " <> cs p - unescape :: TextS.Text -> TextS.Text - unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+" - mapM parsePair xs +instance MimeUnrender EventStream EventStreamChunk where + mimeUnrender _ = Right . EventStreamChunk -- $setup +-- >>> :set -XFlexibleInstances +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XOverloadedStrings -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text diff --git a/src/Servant/API/Description.hs b/src/Servant/API/Description.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Description.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Description ( + -- * Combinators + Description, + Summary, + -- * Used as modifiers + FoldDescription, + FoldDescription', + reflectDescription, + ) where + +import Data.Kind + (Type) +import Data.Proxy + (Proxy (..)) +import Data.Typeable + (Typeable) +import GHC.TypeLits + (KnownSymbol, Symbol, symbolVal) + +-- | Add a short summary for (part of) API. +-- +-- Example: +-- +-- >>> type MyApi = Summary "Get book by ISBN." :> "books" :> Capture "isbn" Text :> Get '[JSON] Book +data Summary (sym :: Symbol) + deriving (Typeable) + +-- | Add more verbose description for (part of) API. +-- +-- Example: +-- +-- >>> :{ +--type MyApi = Description +-- "This comment is visible in multiple Servant interpretations \ +-- \and can be really long if necessary. \ +-- \Haskell multiline String support is not perfect \ +-- \but it's still very readable." +-- :> Get '[JSON] Book +-- :} +data Description (sym :: Symbol) + deriving (Typeable) + +-- | Fold list of modifiers to extract description as a type-level String. +-- +-- >>> :kind! FoldDescription '[] +-- FoldDescription '[] :: Symbol +-- = "" +-- +-- >>> :kind! FoldDescription '[Required, Description "foobar", Lenient] +-- FoldDescription '[Required, Description "foobar", Lenient] :: Symbol +-- = "foobar" +-- +type FoldDescription mods = FoldDescription' "" mods + +-- | Implementation of 'FoldDescription'. +type family FoldDescription' (acc :: Symbol) (mods :: [Type]) :: Symbol where + FoldDescription' acc '[] = acc + FoldDescription' acc (Description desc ': mods) = FoldDescription' desc mods + FoldDescription' acc (mod ': mods) = FoldDescription' acc mods + +-- | Reflect description to the term level. +-- +-- >>> reflectDescription (Proxy :: Proxy '[Required, Description "foobar", Lenient]) +-- "foobar" +-- +reflectDescription :: forall mods. KnownSymbol (FoldDescription mods) => Proxy mods -> String +reflectDescription _ = symbolVal (Proxy :: Proxy (FoldDescription mods)) + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } +-- >>> data SourceFile +-- >>> instance ToJSON SourceFile where { toJSON = undefined } diff --git a/src/Servant/API/Empty.hs b/src/Servant/API/Empty.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Empty.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Empty(EmptyAPI(..)) where + +import Data.Typeable (Typeable) + +-- | An empty API: one which serves nothing. Morally speaking, this should be +-- the unit of ':<|>'. Implementors of interpretations of API types should +-- treat 'EmptyAPI' as close to the unit as possible. +data EmptyAPI = EmptyAPI deriving (Typeable, Eq, Show, Bounded, Enum) 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,10 +1,11 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} + +{-# LANGUAGE PolyKinds #-} module Servant.API.Experimental.Auth where -import Data.Typeable (Typeable) +import Data.Typeable + (Typeable) -- | A generalized Authentication combinator. Use this if you have a -- non-standard authentication technique. 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 @@ -1,16 +1,21 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Header ( - Header(..), -) where + Header, Header', + ) where -import Data.ByteString (ByteString) -import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import Data.Kind + (Type) +import Data.Typeable + (Typeable) +import GHC.TypeLits + (Symbol) +import Servant.API.Modifiers + -- | Extract the given header's value as a value of type @a@. +-- I.e. header sent by client, parsed by server. -- -- Example: -- @@ -18,10 +23,10 @@ -- >>> -- >>> -- GET /view-my-referer -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer -data Header (sym :: Symbol) a = Header a - | MissingHeader - | UndecodableHeader ByteString - deriving (Typeable, Eq, Show, Functor) +type Header = Header' '[Optional, Strict] + +data Header' (mods :: [Type]) (sym :: Symbol) (a :: Type) + deriving Typeable -- $setup -- >>> import Servant.API 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/HttpVersion.hs b/src/Servant/API/HttpVersion.hs --- a/src/Servant/API/HttpVersion.hs +++ b/src/Servant/API/HttpVersion.hs @@ -3,7 +3,8 @@ HttpVersion(..) ) where -import Network.HTTP.Types (HttpVersion (..)) +import Network.HTTP.Types + (HttpVersion (..)) -- $httpversion -- 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,36 +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] () - -type ComprehensiveAPI = - GET :<|> - Get '[JSON] Int :<|> - Capture "foo" Int :> GET :<|> - Header "foo" Int :> GET :<|> - HttpVersion :> GET :<|> - IsSecure :> GET :<|> - QueryParam "foo" Int :> GET :<|> - QueryParams "foo" Int :> GET :<|> - QueryFlag "foo" :> GET :<|> --- Raw :<|> - RemoteHost :> GET :<|> - ReqBody '[JSON] Int :> GET :<|> - Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> - "foo" :> GET :<|> - Vault :> GET :<|> - Verb 'POST 204 '[JSON] () :<|> - Verb 'POST 204 '[JSON] Int :<|> - WithNamedContext "foo" '[] GET - -comprehensiveAPI :: Proxy ComprehensiveAPI -comprehensiveAPI = Proxy diff --git a/src/Servant/API/IsSecure.hs b/src/Servant/API/IsSecure.hs --- a/src/Servant/API/IsSecure.hs +++ b/src/Servant/API/IsSecure.hs @@ -1,10 +1,14 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} module Servant.API.IsSecure ( -- $issecure IsSecure(..) ) where import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) -- | Was this request made over an SSL connection? -- @@ -19,7 +23,7 @@ -- is secure (HTTPS) | NotSecure -- ^ the connection to the server -- is not secure (HTTP) - deriving Typeable + deriving (Eq, Show, Read, Generic, Ord, Typeable) -- $issecure -- diff --git a/src/Servant/API/Modifiers.hs b/src/Servant/API/Modifiers.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Modifiers.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +module Servant.API.Modifiers ( + -- * Required / optional argument + Required, Optional, + FoldRequired, FoldRequired', + -- * Lenient / strict parsing + Lenient, Strict, + FoldLenient, FoldLenient', + -- * Utilities + RequiredArgument, + foldRequiredArgument, + unfoldRequiredArgument, + RequestArgument, + unfoldRequestArgument, + ) where + +import Data.Kind + (Type) +import Data.Proxy + (Proxy (..)) +import Data.Singletons.Bool + (SBool (..), SBoolI (..)) +import Data.Text + (Text) +import Data.Type.Bool + (If) + +-- | Required argument. Not wrapped. +data Required + +-- | Optional argument. Wrapped in 'Maybe'. +data Optional + +-- | Fold modifier list to decide whether argument is required. +-- +-- >>> :kind! FoldRequired '[Required, Description "something"] +-- FoldRequired '[Required, Description "something"] :: Bool +-- = 'True +-- +-- >>> :kind! FoldRequired '[Required, Optional] +-- FoldRequired '[Required, Optional] :: Bool +-- = 'False +-- +-- >>> :kind! FoldRequired '[] +-- FoldRequired '[] :: Bool +-- = 'False +-- +type FoldRequired mods = FoldRequired' 'False mods + +-- | Implementation of 'FoldRequired'. +type family FoldRequired' (acc :: Bool) (mods :: [Type]) :: Bool where + FoldRequired' acc '[] = acc + FoldRequired' acc (Required ': mods) = FoldRequired' 'True mods + FoldRequired' acc (Optional ': mods) = FoldRequired' 'False mods + FoldRequired' acc (mod ': mods) = FoldRequired' acc mods + +-- | Leniently parsed argument, i.e. parsing never fail. Wrapped in @'Either' 'Text'@. +data Lenient + +-- | Strictly parsed argument. Not wrapped. +data Strict + +-- | Fold modifier list to decide whether argument should be parsed strictly or leniently. +-- +-- >>> :kind! FoldLenient '[] +-- FoldLenient '[] :: Bool +-- = 'False +-- +type FoldLenient mods = FoldLenient' 'False mods + +-- | Implementation of 'FoldLenient'. +type family FoldLenient' (acc :: Bool) (mods :: [Type]) :: Bool where + FoldLenient' acc '[] = acc + FoldLenient' acc (Lenient ': mods) = FoldLenient' 'True mods + FoldLenient' acc (Strict ': mods) = FoldLenient' 'False mods + FoldLenient' acc (mod ': mods) = FoldLenient' acc mods + +-- | Helper type alias. +-- +-- * 'Required' ↦ @a@ +-- +-- * 'Optional' ↦ @'Maybe' a@ +-- +type RequiredArgument mods a = If (FoldRequired mods) a (Maybe a) + +-- | Fold a 'RequiredAgument' into a value +foldRequiredArgument + :: forall mods a r. (SBoolI (FoldRequired mods)) + => Proxy mods + -> (a -> r) -- ^ 'Required' + -> (Maybe a -> r) -- ^ 'Optional' + -> RequiredArgument mods a + -> r +foldRequiredArgument _ f g mx = + case (sbool :: SBool (FoldRequired mods), mx) of + (STrue, x) -> f x + (SFalse, x) -> g x + +-- | Unfold a value into a 'RequiredArgument'. +unfoldRequiredArgument + :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) + => Proxy mods + -> m (RequiredArgument mods a) -- ^ error when argument is required + -> (Text -> m (RequiredArgument mods a)) -- ^ error when argument is strictly parsed + -> Maybe (Either Text a) -- ^ value + -> m (RequiredArgument mods a) +unfoldRequiredArgument _ errReq errSt mex = + case (sbool :: SBool (FoldRequired mods), mex) of + (STrue, Nothing) -> errReq + (SFalse, Nothing) -> return Nothing + (STrue, Just ex) -> either errSt return ex + (SFalse, Just ex) -> either errSt (return . Just) ex + +-- | Helper type alias. +-- +-- By default argument is 'Optional' and 'Strict'. +-- +-- * 'Required', 'Strict' ↦ @a@ +-- +-- * 'Required', 'Lenient' ↦ @'Either' 'Text' a@ +-- +-- * 'Optional', 'Strict' ↦ @'Maybe' a@ +-- +-- * 'Optional', 'Lenient' ↦ @'Maybe' ('Either' 'Text' a)@ +-- +type RequestArgument mods a = + If (FoldRequired mods) + (If (FoldLenient mods) (Either Text a) a) + (Maybe (If (FoldLenient mods) (Either Text a) a)) + +-- | Unfold a value into a 'RequestArgument'. +unfoldRequestArgument + :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) + => Proxy mods + -> m (RequestArgument mods a) -- ^ error when argument is required + -> (Text -> m (RequestArgument mods a)) -- ^ error when argument is strictly parsed + -> Maybe (Either Text a) -- ^ value + -> m (RequestArgument mods a) +unfoldRequestArgument _ errReq errSt mex = + case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of + (STrue, Nothing, _) -> errReq + (SFalse, Nothing, _) -> return Nothing + (STrue, Just ex, STrue) -> return ex + (STrue, Just ex, SFalse) -> either errSt return ex + (SFalse, Just ex, STrue) -> return (Just ex) + (SFalse, Just ex, SFalse) -> either errSt (return . Just) ex + +-- $setup +-- >>> import Servant.API 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,12 +1,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-} + {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where +module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where -import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import Data.Kind + (Type) +import Data.Typeable + (Typeable) +import GHC.TypeLits + (Symbol) +import Servant.API.Modifiers + -- | Lookup the value associated to the @sym@ query string parameter -- and try to extract it as a value of type @a@. -- @@ -14,7 +20,10 @@ -- -- >>> -- /books?author= -- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -data QueryParam (sym :: Symbol) a +type QueryParam = QueryParam' '[Optional, Strict] + +-- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise. +data QueryParam' (mods :: [Type]) (sym :: Symbol) (a :: Type) deriving Typeable -- | Lookup the values associated to the @sym@ query string parameter @@ -28,7 +37,7 @@ -- -- >>> -- /books?authors[]=&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 @@ -2,13 +2,19 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Raw where -import Data.Typeable (Typeable) +import Data.Typeable + (Typeable) + -- | Endpoint for plugging in your own Wai 'Application's. -- -- The given 'Application' will get the request as received by the server, potentially with -- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's, --- this can also be used with 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/RemoteHost.hs b/src/Servant/API/RemoteHost.hs --- a/src/Servant/API/RemoteHost.hs +++ b/src/Servant/API/RemoteHost.hs @@ -5,6 +5,7 @@ ) where import Data.Typeable + (Typeable) -- | Provides access to the host or IP address -- from which the HTTP request was sent. @@ -12,7 +13,7 @@ -- $remotehost -- --- | Use 'RemoteHost' whenever your request handlers need the host or IP address +-- Use 'RemoteHost' whenever your request handlers need the host or IP address -- from which the client issued the HTTP request. The corresponding handlers -- receive arguments of type @SockAddr@ (from @Network.Socket@). -- 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 @@ -2,16 +2,28 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.ReqBody where +module Servant.API.ReqBody ( + ReqBody, ReqBody', + ) where -import Data.Typeable (Typeable) +import Data.Kind + (Type) +import Data.Typeable + (Typeable) +import Servant.API.Modifiers + -- | Extract the request body as a value of type @a@. -- -- Example: -- -- >>> -- POST /books -- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -data ReqBody (contentTypes :: [*]) a +type ReqBody = ReqBody' '[Required, Strict] + +-- | +-- +-- /Note:/ 'ReqBody'' is always 'Required'. +data ReqBody' (mods :: [Type]) (contentTypes :: [Type]) (a :: Type) deriving (Typeable) -- $setup 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,20 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int @@ -23,104 +9,256 @@ -- example above). module Servant.API.ResponseHeaders ( Headers(..) - , AddHeader(addHeader) + , ResponseHeader (..) + , AddHeader + , addHeader + , addHeader' + , noHeader + , noHeader' + , HasResponseHeader + , lookupResponseHeader , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders) + , GetHeaders' , HeaderValMap , HList(..) ) where -import Data.ByteString.Char8 as BS (pack, unlines, init) -import Data.ByteString.Conversion (ToByteString, toByteString', - FromByteString, fromByteString) -import qualified Data.CaseInsensitive as CI +import Control.DeepSeq + (NFData (..)) +import Data.ByteString.Char8 as BS + (ByteString, pack) +import qualified Data.CaseInsensitive as CI +import Data.Kind + (Type) +import qualified Data.List as L import Data.Proxy -import GHC.TypeLits (KnownSymbol, symbolVal) -import qualified Network.HTTP.Types.Header as HTTP +import Data.Typeable + (Typeable) +import GHC.TypeLits + (KnownSymbol, Symbol, symbolVal) +import qualified Network.HTTP.Types.Header as HTTP +import Web.HttpApiData + (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) -import Servant.API.Header (Header (..)) -import Prelude () -import Prelude.Compat +import Servant.API.Header + (Header') +import Servant.API.Modifiers + (Optional, Strict) +import Servant.API.UVerb.Union +import qualified Data.SOP.BasicFunctors as SOP +import qualified Data.SOP.NS as SOP -- | Response Header objects. You should never need to construct one directly. --- Instead, use 'addHeader'. +-- Instead, use 'addOptionalHeader'. data Headers ls a = Headers { getResponse :: a -- ^ The underlying value of a 'Headers' , getHeadersHList :: HList ls -- ^ HList of headers. } deriving (Functor) +instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where + rnf (Headers x hdrs) = rnf x `seq` rnf hdrs + +data ResponseHeader (sym :: Symbol) a + = Header a + | MissingHeader + | UndecodableHeader ByteString + deriving (Typeable, Eq, Show, Functor) + +instance NFData a => NFData (ResponseHeader sym a) where + rnf MissingHeader = () + rnf (UndecodableHeader bs) = rnf bs + rnf (Header x) = rnf x + data HList a where HNil :: HList '[] - HCons :: Header h x -> HList xs -> HList (Header h x ': xs) + HCons :: ResponseHeader h x -> HList xs -> HList (Header' mods h x ': xs) -type family HeaderValMap (f :: * -> *) (xs :: [*]) where +class NFDataHList xs where rnfHList :: HList xs -> () +instance NFDataHList '[] where rnfHList HNil = () +instance (y ~ Header' mods h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where + rnfHList (HCons h xs) = rnf h `seq` rnfHList xs + +instance NFDataHList xs => NFData (HList xs) where + rnf = rnfHList + +type family HeaderValMap (f :: Type -> Type) (xs :: [Type]) where HeaderValMap f '[] = '[] - HeaderValMap f (Header h x ': xs) = Header h (f x) ': (HeaderValMap f xs) + HeaderValMap f (Header' mods h x ': xs) = Header' mods h (f x) ': HeaderValMap f xs class BuildHeadersTo hs where buildHeadersTo :: [HTTP.Header] -> HList hs - -- ^ Note: if there are multiple occurences of a header in the argument, - -- the values are interspersed with commas before deserialization (see - -- ) -instance OVERLAPPING_ BuildHeadersTo '[] where +instance {-# OVERLAPPING #-} BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance OVERLAPPABLE_ ( FromByteString 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 fromByteString (BS.init $ BS.unlines xs) of - Nothing -> UndecodableHeader (BS.init $ BS.unlines xs) - `HCons` buildHeadersTo headers - Just h -> Header h `HCons` buildHeadersTo headers +-- The current implementation does not manipulate HTTP header field lines in any way, +-- like merging field lines with the same field name in a single line. +instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) + => BuildHeadersTo (Header' mods h v ': xs) where + buildHeadersTo headers = case L.find wantedHeader headers of + Nothing -> MissingHeader `HCons` buildHeadersTo headers + Just header@(_, val) -> case parseHeader val of + Left _err -> UndecodableHeader val `HCons` buildHeadersTo (L.delete header headers) + Right h -> Header h `HCons` buildHeadersTo (L.delete header headers) + where wantedHeader (h, _) = h == wantedHeaderName + wantedHeaderName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) --- * Getting +-- * Getting headers class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -instance OVERLAPPING_ GetHeaders (HList '[]) where - getHeaders _ = [] +-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance +class GetHeadersFromHList hs where + getHeadersFromHList :: HList hs -> [HTTP.Header] -instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) ) - => GetHeaders (HList (Header h x ': xs)) where - getHeaders hdrs = case hdrs of - Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest - UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest - MissingHeader `HCons` rest -> getHeaders rest - where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) +instance GetHeadersFromHList hs => GetHeaders (HList hs) where + getHeaders = getHeadersFromHList -instance OVERLAPPING_ GetHeaders (Headers '[] a) where - getHeaders _ = [] +instance GetHeadersFromHList '[] where + getHeadersFromHList _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v ) - => GetHeaders (Headers (Header h v ': rest) a) where - getHeaders hs = getHeaders $ getHeadersHList hs +instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs) + => GetHeadersFromHList (Header' mods h x ': xs) + where + getHeadersFromHList hdrs = case hdrs of + Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest + UndecodableHeader h `HCons` rest -> (headerName, h) : getHeadersFromHList rest + MissingHeader `HCons` rest -> getHeadersFromHList rest + where + headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) --- * Adding +-- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance +class GetHeaders' hs where + getHeaders' :: Headers hs a -> [HTTP.Header] +instance GetHeaders' hs => GetHeaders (Headers hs a) where + getHeaders = getHeaders' + +-- | This instance is an optimisation +instance GetHeaders' '[] where + getHeaders' _ = [] + +instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v) + => GetHeaders' (Header' mods h v ': rest) + where + getHeaders' hs = getHeadersFromHList $ getHeadersHList hs + +-- * Adding headers + -- We need all these fundeps to save type inference -class AddHeader h v orig new - | h v orig -> new, new -> h, new -> v, new -> orig where - addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times +class AddHeader (mods :: [Type]) h v orig new + | mods h v orig -> new, new -> mods, new -> h, new -> v, new -> orig where + addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times +-- In this instance, we add a Header on top of something that is already decorated with some headers +instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v ) + => AddHeader mods h v (Headers (fst ': rest) a) (Headers (Header' mods h v ': fst ': rest) a) where + addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads) -instance OVERLAPPING_ ( KnownSymbol h, ToByteString v ) - => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where - addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) +-- In this instance, 'a' parameter is decorated with a Header. +instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header' mods h v] a) + => AddHeader mods h v a new where + addOptionalHeader hdr resp = Headers resp (HCons hdr HNil) -instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a) ) - => AddHeader h v a new where - addHeader a resp = Headers resp (HCons (Header a) HNil) +-- Instances to decorate all responses in a 'Union' with headers. The functional +-- dependencies force us to consider singleton lists as the base case in the +-- recursion (it is impossible to determine h and v otherwise from old / new +-- responses if the list is empty). +instance (AddHeader mods h v old new) => AddHeader mods h v (Union '[old]) (Union '[new]) where + addOptionalHeader hdr resp = + SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ resp +instance + ( AddHeader mods h v old new, AddHeader mods h v (Union oldrest) (Union newrest) + -- This ensures that the remainder of the response list is _not_ empty + -- It is necessary to prevent the two instances for union types from + -- overlapping. + , oldrest ~ (a ': as), newrest ~ (b ': bs)) + => AddHeader mods h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where + addOptionalHeader hdr resp = case resp of + SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead + SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers + +-- | @addHeader@ adds a header to a response. Note that it changes the type of +-- the value in the following ways: +-- +-- 1. A simple value is wrapped in "Headers '[hdr]": +-- +-- >>> let example0 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; +-- >>> getHeaders example0 +-- [("someheader","5")] +-- +-- 2. A value that already has a header has its new header *prepended* to the +-- existing list: +-- +-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; +-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String +-- >>> getHeaders example2 +-- [("1st","true"),("someheader","5")] +-- +-- Note that while in your handlers type annotations are not required, since +-- the type can be inferred from the API type, in other cases you may find +-- yourself needing to add annotations. +addHeader :: AddHeader '[Optional, Strict] h v orig new => v -> orig -> new +addHeader = addOptionalHeader . Header + +-- | Same as 'addHeader' but works with `Header'`, so it's possible to use any @mods@. +addHeader' :: AddHeader mods h v orig new => v -> orig -> new +addHeader' = addOptionalHeader . Header + +-- | Deliberately do not add a header to a value. +-- +-- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String +-- >>> getHeaders example1 +-- [] +noHeader :: AddHeader '[Optional, Strict] h v orig new => orig -> new +noHeader = addOptionalHeader MissingHeader + +-- | Same as 'noHeader' but works with `Header'`, so it's possible to use any @mods@. +noHeader' :: AddHeader mods h v orig new => orig -> new +noHeader' = addOptionalHeader MissingHeader + +class HasResponseHeader h a headers where + hlistLookupHeader :: HList headers -> ResponseHeader h a + +instance {-# OVERLAPPING #-} HasResponseHeader h a (Header' mods h a ': rest) where + hlistLookupHeader (HCons ha _) = ha + +instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where + hlistLookupHeader (HCons _ hs) = hlistLookupHeader hs + +-- | Look up a specific ResponseHeader, +-- without having to know what position it is in the HList. +-- +-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String +-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String +-- >>> lookupResponseHeader example2 :: ResponseHeader "someheader" Int +-- Header 5 +-- +-- >>> lookupResponseHeader example2 :: ResponseHeader "1st" Bool +-- Header True +-- +-- Usage of this function relies on an explicit type annotation of the header to be looked up. +-- This can be done with type annotations on the result, or with an explicit type application. +-- In this example, the type of header value is determined by the type-inference, +-- we only specify the name of the header: +-- +-- >>> :set -XTypeApplications +-- >>> case lookupResponseHeader @"1st" example2 of { Header b -> b ; _ -> False } +-- True +-- +-- @since 0.15 +-- +lookupResponseHeader :: (HasResponseHeader h a headers) + => Headers headers r -> ResponseHeader h a +lookupResponseHeader = hlistLookupHeader . getHeadersHList + -- $setup +-- >>> :set -XFlexibleContexts -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text 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 new file mode 100644 --- /dev/null +++ b/src/Servant/API/Stream.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} + + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK not-home #-} + +module Servant.API.Stream ( + Stream, + StreamGet, + StreamPost, + StreamBody, + StreamBody', + -- * Source + -- + -- | 'SourceIO' are equivalent to some *source* in streaming libraries. + SourceIO, + ToSourceIO (..), + FromSourceIO (..), + -- ** Auxiliary classes + SourceToSourceIO (..), + -- * Framing + FramingRender (..), + FramingUnrender (..), + -- ** Strategies + NoFraming, + NewlineFraming, + NetstringFraming, + ) where + + +import Control.Applicative + ((<|>)) +import Control.Monad.IO.Class + (MonadIO (..)) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.Kind + (Type) +import Data.List.NonEmpty + (NonEmpty (..)) +import Data.Proxy + (Proxy) +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import GHC.TypeLits + (Nat) +import Network.HTTP.Types.Method + (StdMethod (..)) +import Servant.Types.SourceT + +-- | A Stream endpoint for a given method emits a stream of encoded values at a +-- given @Content-Type@, delimited by a @framing@ strategy. +-- Type synonyms are provided for standard methods. +-- +data Stream (method :: k1) (status :: Nat) (framing :: Type) (contentType :: Type) (a :: Type) + deriving (Typeable, Generic) + +type StreamGet = Stream 'GET 200 +type StreamPost = Stream 'POST 200 + +-- | A stream request body. +type StreamBody = StreamBody' '[] + +data StreamBody' (mods :: [Type]) (framing :: Type) (contentType :: Type) (a :: Type) + deriving (Typeable, Generic) + +------------------------------------------------------------------------------- +-- Sources +------------------------------------------------------------------------------- + +-- | Stream endpoints may be implemented as producing a @'SourceIO' chunk@. +-- +-- Clients reading from streaming endpoints can be implemented as consuming a +-- @'SourceIO' chunk@. +-- +type SourceIO = SourceT IO + +-- | 'ToSourceIO' is intended to be implemented for types such as Conduit, Pipe, +-- etc. By implementing this class, all such streaming abstractions can be used +-- directly as endpoints. +class ToSourceIO chunk a | a -> chunk where + toSourceIO :: a -> SourceIO chunk + +-- | Auxiliary class for @'ToSourceIO' x ('SourceT' m x)@ instance. +class SourceToSourceIO m where + sourceToSourceIO :: SourceT m a -> SourceT IO a + +instance SourceToSourceIO IO where + sourceToSourceIO = id + +-- | Relax to use auxiliary class, have m +instance SourceToSourceIO m => ToSourceIO chunk (SourceT m chunk) where + toSourceIO = sourceToSourceIO + +instance ToSourceIO a (NonEmpty a) where + toSourceIO (x :| xs) = fromStepT (Yield x (foldr Yield Stop xs)) + +instance ToSourceIO a [a] where + toSourceIO = source + +-- | 'FromSourceIO' is intended to be implemented for types such as Conduit, +-- Pipe, etc. By implementing this class, all such streaming abstractions can +-- be used directly on the client side for talking to streaming endpoints. +class FromSourceIO chunk a | a -> chunk where + fromSourceIO :: SourceIO chunk -> IO a + +instance MonadIO m => FromSourceIO a (SourceT m a) where + fromSourceIO = return . sourceFromSourceIO + +sourceFromSourceIO :: forall m a. MonadIO m => SourceT IO a -> SourceT m a +sourceFromSourceIO src = + SourceT $ \k -> + k $ Effect $ liftIO $ unSourceT src (return . go) + where + go :: StepT IO a -> StepT m a + go Stop = Stop + go (Error err) = Error err + go (Skip s) = Skip (go s) + go (Effect ms) = Effect (liftIO (fmap go ms)) + go (Yield x s) = Yield x (go s) + +-- This fires e.g. in Client.lhs +-- {-# OPTIONS_GHC -ddump-simpl -ddump-rule-firings -ddump-to-file #-} +{-# NOINLINE [2] sourceFromSourceIO #-} +{-# RULES "sourceFromSourceIO @IO" sourceFromSourceIO = id :: SourceT IO a -> SourceT IO a #-} + +------------------------------------------------------------------------------- +-- Framing +------------------------------------------------------------------------------- + +-- | The 'FramingRender' class provides the logic for emitting a framing strategy. +-- The strategy transforms a @'SourceT' m a@ into @'SourceT' m 'LBS.ByteString'@, +-- therefore it can prepend, append and intercalate /framing/ structure +-- around chunks. +-- +-- /Note:/ as the @'Monad' m@ is generic, this is pure transformation. +-- +class FramingRender strategy where + framingRender :: Monad m => Proxy strategy -> (a -> LBS.ByteString) -> SourceT m a -> SourceT m LBS.ByteString + +-- | The 'FramingUnrender' class provides the logic for parsing a framing +-- strategy. +class FramingUnrender strategy where + framingUnrender :: Monad m => Proxy strategy -> (LBS.ByteString -> Either String a) -> SourceT m BS.ByteString -> SourceT m a + +------------------------------------------------------------------------------- +-- NoFraming +------------------------------------------------------------------------------- + +-- | A framing strategy that does not do any framing at all, it just passes the +-- input data This will be used most of the time with binary data, such as +-- files +data NoFraming + +instance FramingRender NoFraming where + framingRender _ = fmap + +-- | As 'NoFraming' doesn't have frame separators, we take the chunks +-- as given and try to convert them one by one. +-- +-- That works well when @a@ is a 'ByteString'. +instance FramingUnrender NoFraming where + framingUnrender _ f = mapStepT go + where + go Stop = Stop + go (Error err) = Error err + go (Skip s) = Skip (go s) + go (Effect ms) = Effect (fmap go ms) + go (Yield x s) = case f (LBS.fromStrict x) of + Right y -> Yield y (go s) + Left err -> Error err + +------------------------------------------------------------------------------- +-- NewlineFraming +------------------------------------------------------------------------------- + +-- | A simple framing strategy that has no header, and inserts a +-- newline character after each frame. This assumes that it is used with a +-- Content-Type that encodes without newlines (e.g. JSON). +data NewlineFraming + +instance FramingRender NewlineFraming where + framingRender _ f = fmap (\x -> f x <> "\n") + +instance FramingUnrender NewlineFraming where + framingUnrender _ f = transformWithAtto $ do + bs <- A.takeWhile (/= 10) + () <$ A.word8 10 <|> A.endOfInput + either fail pure (f (LBS.fromStrict bs)) + +------------------------------------------------------------------------------- +-- NetstringFraming +------------------------------------------------------------------------------- + +-- | The netstring framing strategy as defined by djb: +-- +-- +-- Any string of 8-bit bytes may be encoded as @[len]":"[string]","@. Here +-- @[string]@ is the string and @[len]@ is a nonempty sequence of ASCII digits +-- giving the length of @[string]@ in decimal. The ASCII digits are @<30>@ for +-- 0, @<31>@ for 1, and so on up through @<39>@ for 9. Extra zeros at the front +-- of @[len]@ are prohibited: @[len]@ begins with @<30>@ exactly when +-- @[string]@ is empty. +-- +-- For example, the string @"hello world!"@ is encoded as +-- @<31 32 3a 68 65 6c 6c 6f 20 77 6f 72 6c 64 21 2c>@, +-- i.e., @"12:hello world!,"@. +-- The empty string is encoded as @"0:,"@. +-- +data NetstringFraming + +instance FramingRender NetstringFraming where + framingRender _ f = fmap $ \x -> + let bs = f x + in LBS8.pack (show (LBS8.length bs)) <> ":" <> bs <> "," + +instance FramingUnrender NetstringFraming where + framingUnrender _ f = transformWithAtto $ do + len <- A8.decimal + _ <- A8.char ':' + bs <- A.take len + _ <- A8.char ',' + either fail pure (f (LBS.fromStrict bs)) 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,7 +4,10 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Sub ((:>)) where -import Data.Typeable (Typeable) +import Data.Kind + (Type) +import Data.Typeable + (Typeable) -- | The contained API (second argument) can be found under @("/" ++ path)@ -- (path being the first argument). @@ -14,9 +17,9 @@ -- >>> -- 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 9 :> +infixr 4 :> -- $setup -- >>> import Servant.API 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 new file mode 100644 --- /dev/null +++ b/src/Servant/API/TypeLevel.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{-| +This module collects utilities for manipulating @servant@ API types. The +functionality in this module is for advanced usage. + +The code samples in this module use the following type synonym: + +> type SampleAPI = "hello" :> Get '[JSON] Int +> :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool + +-} +module Servant.API.TypeLevel ( + -- $setup + -- * API predicates + Endpoints, + -- ** Lax inclusion + IsElem', + IsElem, + IsSubAPI, + AllIsElem, + -- ** Strict inclusion + IsIn, + IsStrictSubAPI, + AllIsIn, + -- * Helpers + -- ** Lists + MapSub, + AppendList, + IsSubList, + Elem, + ElemGo, + -- ** Logic + Or, + And, + -- ** Fragment + FragmentUnique, + AtMostOneFragment + ) where + + +import GHC.Exts + (Constraint) +import Data.Kind + (Type) +import Servant.API.Alternative + (type (:<|>)) +import Servant.API.Capture + (Capture, CaptureAll) +import Servant.API.Fragment +import Servant.API.Header + (Header, Header') +import Servant.API.QueryParam + (QueryFlag, QueryParam, QueryParams) +import Servant.API.ReqBody + (ReqBody) +import Servant.API.NamedRoutes + (NamedRoutes) +import Servant.API.Generic + (ToServantApi) +import Servant.API.Sub + (type (:>)) +import Servant.API.Verbs + (Verb) +import Servant.API.UVerb + (UVerb) +import GHC.TypeLits + (ErrorMessage (..), TypeError) + + + +-- * API predicates + +-- | Flatten API into a list of endpoints. +-- +-- >>> Refl :: Endpoints SampleAPI :~: '["hello" :> Verb 'GET 200 '[JSON] Int, "bye" :> (Capture "name" String :> Verb 'POST 200 '[JSON, PlainText] Bool)] +-- Refl +type family Endpoints api where + Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b) + Endpoints (e :> a) = MapSub e (Endpoints a) + Endpoints a = '[a] + +-- ** Lax inclusion + +-- | You may use this type family to tell the type checker that your custom +-- type may be skipped as part of a link. This is useful for things like +-- @'QueryParam'@ that are optional in a URI and do not affect them if they are +-- omitted. +-- +-- >>> data CustomThing +-- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s +-- +-- Note that @'IsElem'@ is called, which will mutually recurse back to @'IsElem''@ +-- if it exhausts all other options again. +-- +-- Once you have written a @HasLink@ instance for @CustomThing@ you are ready to go. +type family IsElem' a s :: Constraint + +-- | Closed type family, check if @endpoint@ is within @api@. +-- Uses @'IsElem''@ if it exhausts all other options. +-- +-- >>> ok (Proxy :: Proxy (IsElem ("hello" :> Get '[JSON] Int) SampleAPI)) +-- OK +-- +-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI)) +-- ... +-- ... Could not ... +-- ... +-- +-- An endpoint is considered within an api even if it is missing combinators +-- that don't affect the URL: +-- +-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))) +-- OK +-- +-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (ReqBody '[JSON] Bool :> Get '[JSON] Int))) +-- OK +-- +-- *N.B.:* @IsElem a b@ can be seen as capturing the notion of whether the URL +-- represented by @a@ would match the URL represented by @b@, *not* whether a +-- request represented by @a@ matches the endpoints serving @b@ (for the +-- latter, use 'IsIn'). +type family IsElem endpoint api :: Constraint where + IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) + IsElem (e :> sa) (e :> sb) = IsElem sa sb + IsElem sa (Header sym x :> sb) = IsElem sa sb + IsElem sa (Header' mods sym x :> sb) = IsElem sa sb + IsElem sa (ReqBody y x :> sb) = IsElem sa sb + IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) + = IsElem sa sb + IsElem (Capture z y :> sa) (Capture x y :> sb) + = IsElem sa sb + IsElem sa (QueryParam x y :> sb) = IsElem sa sb + IsElem sa (QueryParams x y :> sb) = IsElem sa sb + IsElem sa (QueryFlag x :> sb) = IsElem sa sb + IsElem sa (Fragment x :> sb) = IsElem sa sb + IsElem (Verb m s ct typ) (Verb m s ct' typ) + = IsSubList ct ct' + IsElem e e = () + IsElem e (NamedRoutes rs) = IsElem e (ToServantApi rs) + IsElem e a = IsElem' e a + +-- | Check whether @sub@ is a sub-API of @api@. +-- +-- >>> ok (Proxy :: Proxy (IsSubAPI SampleAPI (SampleAPI :<|> Get '[JSON] Int))) +-- OK +-- +-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI)) +-- ... +-- ... Could not ... +-- ... +-- +-- This uses @IsElem@ for checking; thus the note there applies here. +type family IsSubAPI sub api :: Constraint where + IsSubAPI sub api = AllIsElem (Endpoints sub) api + +-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsElem'@). +type family AllIsElem xs api :: Constraint where + AllIsElem '[] api = () + AllIsElem (x ': xs) api = (IsElem x api, AllIsElem xs api) + +-- ** Strict inclusion + +-- | Closed type family, check if @endpoint@ is exactly within @api@. +-- +-- >>> ok (Proxy :: Proxy (IsIn ("hello" :> Get '[JSON] Int) SampleAPI)) +-- OK +-- +-- Unlike 'IsElem', this requires an *exact* match. +-- +-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int))) +-- ... +-- ... Could not ... +-- ... +type family IsIn (endpoint :: Type) (api :: Type) :: Constraint where + IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb) + IsIn (e :> sa) (e :> sb) = IsIn sa sb + IsIn e e = () + IsIn e (NamedRoutes record) = IsIn e (ToServantApi record) + +-- | Check whether @sub@ is a sub API of @api@. +-- +-- Like 'IsSubAPI', but uses 'IsIn' rather than 'IsElem'. +type family IsStrictSubAPI sub api :: Constraint where + IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api + +-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@). +-- +-- >>> ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI)) +-- OK +type family AllIsIn xs api :: Constraint where + AllIsIn '[] api = () + AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api) + +-- * Helpers + +-- ** Lists + +-- | Apply @(e :>)@ to every API in @xs@. +type family MapSub e xs where + MapSub e '[] = '[] + MapSub e (x ': xs) = (e :> x) ': MapSub e xs + +-- | Append two type-level lists. +type family AppendList xs ys where + AppendList '[] ys = ys + AppendList (x ': xs) ys = x ': AppendList xs ys + +type family IsSubList a b :: Constraint where + IsSubList '[] b = () + IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y + +-- | Check that a value is an element of a list: +-- +-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool])) +-- OK +-- +-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool])) +-- ... +-- ... [Char]...'[Int, Bool... +-- ... +type Elem e es = ElemGo e es es + +-- 'orig' is used to store original list for better error messages +type family ElemGo e es orig :: Constraint where + ElemGo x (x ': xs) orig = () + ElemGo y (x ': xs) orig = ElemGo y xs orig + -- Note [Custom Errors] + ElemGo x '[] orig = TypeError ('ShowType x + ':<>: 'Text " expected in list " + ':<>: 'ShowType orig) + +-- ** Logic + +-- | If either 'a' or 'b' produce an empty constraint, produce an empty constraint. +type family Or (a :: Constraint) (b :: Constraint) :: Constraint where + -- This works because of: + -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap + Or () b = () + Or a () = () + +-- | If both 'a' or 'b' produce an empty constraint, produce an empty constraint. +type family And (a :: Constraint) (b :: Constraint) :: Constraint where + And () () = () + +{- Note [Custom Errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We might try to factor these our more cleanly, but the type synonyms and type +families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). +-} + +-- ** Fragment + +-- | If there is more than one fragment in an API endpoint, +-- a compile-time error is raised. +-- +-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent +-- >>> instance AtMostOneFragment FailAPI +-- ... +-- ...Only one Fragment allowed per endpoint in api... +-- ... +class FragmentUnique api => AtMostOneFragment api + +instance AtMostOneFragment (Verb m s ct typ) + +instance AtMostOneFragment (UVerb m cts as) + +instance AtMostOneFragment (Fragment a) + +type family FragmentUnique api :: Constraint where + FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb) + FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa) + FragmentUnique (x :> sa) = FragmentUnique sa + FragmentUnique (Fragment a) = () + FragmentUnique x = () + +type family FragmentNotIn api orig :: Constraint where + FragmentNotIn (sa :<|> sb) orig = + And (FragmentNotIn sa orig) (FragmentNotIn sb orig) + FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig + FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn x orig = () + +type NotUniqueFragmentInApi api = + 'Text "Only one Fragment allowed per endpoint in api ‘" + ':<>: 'ShowType api + ':<>: 'Text "’." + +-- $setup +-- +-- The doctests in this module are run with following preamble: +-- +-- >>> :set -XPolyKinds +-- >>> :set -XGADTs +-- >>> :set -XTypeSynonymInstances -XFlexibleInstances +-- >>> import Data.Proxy +-- >>> import Data.Type.Equality +-- >>> import Servant.API +-- >>> data OK ctx where OK :: ctx => OK ctx +-- >>> instance Show (OK ctx) where show _ = "OK" +-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK +-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool +-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent +-- >>> let sampleAPI = Proxy :: Proxy SampleAPI 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/Vault.hs b/src/Servant/API/Vault.hs --- a/src/Servant/API/Vault.hs +++ b/src/Servant/API/Vault.hs @@ -3,7 +3,8 @@ Vault ) where -import Data.Vault.Lazy (Vault) +import Data.Vault.Lazy + (Vault) -- $vault -- 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,31 +1,42 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} + {-# LANGUAGE PolyKinds #-} module Servant.API.Verbs ( module Servant.API.Verbs , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH) ) where -import Data.Typeable (Typeable) -import Data.Proxy (Proxy) -import GHC.Generics (Generic) -import GHC.TypeLits (Nat) -import Network.HTTP.Types.Method (Method, StdMethod (..), - methodDelete, methodGet, methodHead, - methodPatch, methodPost, methodPut, - methodTrace, methodConnect, - methodOptions) +import Data.Kind + (Type) +import Data.Proxy + (Proxy) +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import GHC.TypeLits + (Nat) +import Network.HTTP.Types.Method + (Method, StdMethod (..), methodConnect, methodDelete, + methodGet, methodHead, methodOptions, methodPatch, methodPost, + methodPut, methodTrace) -- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For -- convenience, type synonyms for each verb with a 200 response code are -- provided, but you are free to define your own: -- -- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a -data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a +data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type) deriving (Typeable, Generic) +-- | @NoContentVerb@ is a specific type to represent 'NoContent' responses. +-- It does not require either a list of content types (because there's +-- no content) or a status code (because it should always be 204). +data NoContentVerb (method :: k1) + deriving (Typeable, Generic) + -- * 200 responses -- -- The 200 response is the workhorse of web servers, but also fairly generic. @@ -53,14 +64,17 @@ -- Indicates that a new resource has been created. The URI corresponding to the -- resource should be given in the @Location@ header field. -- +-- If the operation is idempotent, use 'PutCreated'. If not, use 'PostCreated' +-- -- If the resource cannot be created immediately, use 'PostAccepted'. -- --- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header +-- Consider using 'Servant.Links.safeLink' for the @Location@ header -- field. -- | 'POST' with 201 status code. --- type PostCreated = Verb 'POST 201 +-- | 'PUT' with 201 status code. +type PutCreated = Verb 'PUT 201 -- ** 202 Accepted @@ -107,16 +121,17 @@ -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code. -type GetNoContent = Verb 'GET 204 +type GetNoContent = NoContentVerb 'GET -- | 'POST' with 204 status code. -type PostNoContent = Verb 'POST 204 +type PostNoContent = NoContentVerb 'POST -- | 'DELETE' with 204 status code. -type DeleteNoContent = Verb 'DELETE 204 +type DeleteNoContent = NoContentVerb 'DELETE -- | 'PATCH' with 204 status code. -type PatchNoContent = Verb 'PATCH 204 +type PatchNoContent = NoContentVerb 'PATCH -- | 'PUT' with 204 status code. -type PutNoContent = Verb 'PUT 204 - +type PutNoContent = NoContentVerb 'PUT +-- | 'HEAD' with 204 status code. +type HeadNoContent = NoContentVerb 'HEAD -- ** 205 Reset Content -- 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 @@ -1,9 +1,11 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} module Servant.API.WithNamedContext where -import GHC.TypeLits +import GHC.TypeLits +import Data.Kind + (Type) -- | 'WithNamedContext' names a specific tagged context to use for the -- combinators in the API. (See also in @servant-server@, @@ -18,4 +20,4 @@ -- 'Context's are only relevant for @servant-server@. -- -- For more information, see the tutorial. -data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi +data WithNamedContext (name :: Symbol) (subContext :: [Type]) subApi 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,97 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.Utils.Enter where - -import qualified Control.Category as C -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except -#endif -import Control.Monad.Identity -import Control.Monad.Morph -import Control.Monad.Reader -import qualified Control.Monad.State.Lazy as LState -import qualified Control.Monad.State.Strict as SState -import qualified Control.Monad.Writer.Lazy as LWriter -import qualified Control.Monad.Writer.Strict as SWriter -import Data.Typeable -import Prelude () -import Prelude.Compat - -import Servant.API - -class Enter typ arg ret | typ arg -> ret, typ ret -> arg where - enter :: arg -> typ -> ret - --- ** Servant combinators -instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2 - , arg1 ~ arg2 - ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where - enter e (a :<|> b) = enter e a :<|> enter e b - -instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where - enter arg f a = enter arg (f a) - --- ** Useful instances - --- | A natural transformation from @m@ to @n@. Used to `enter` particular --- datatypes. -newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable - -instance C.Category (:~>) where - id = Nat id - Nat f . Nat g = Nat (f . g) - -instance Enter (m a) (m :~> n) (n a) where - enter (Nat f) = f - --- | Like `lift`. -liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m -liftNat = Nat Control.Monad.Morph.lift - -runReaderTNat :: r -> (ReaderT r m :~> m) -runReaderTNat a = Nat (`runReaderT` a) - -evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) -evalStateTLNat a = Nat (`LState.evalStateT` a) - -evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) -evalStateTSNat a = Nat (`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 = Nat $ \x -> do - (a, w) <- SWriter.runWriterT x - liftIO $ logger w - return a - --- | Like `logWriterTSNat`, but for strict @WriterT@. -logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) -logWriterTLNat logger = Nat $ \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 (Nat n) = Nat $ hoist n - --- | Like @mmorph@'s `embed`. -embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) -embedNat (Nat n) = Nat $ embed n - --- | Like @mmorph@'s `squash`. -squashNat :: (Monad m, MMonad t) => t (t m) :~> t m -squashNat = Nat squash - --- | Like @mmorph@'s `generalize`. -generalizeNat :: Applicative m => Identity :~> m -generalizeNat = Nat (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,301 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# 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] () --- >>> 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 'URI' 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) --- >>> print (safeLink api hello :: URI) --- 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] ()) --- >>> print $ safeLink api with (Just "Hubert") --- bye?name=Hubert --- --- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] ()) --- >>> print $ safeLink api without --- bye --- --- If you would like create a helper for generating links only within that API, --- you can partially apply safeLink if you specify a correct type signature --- like so: --- --- >>> :set -XConstraintKinds --- >>> :{ --- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) --- >>> => Proxy endpoint -> MkLink endpoint --- >>> apiLink = safeLink api --- >>> :} --- --- Attempting to construct a link to an endpoint that does not exist in api --- will result in a type error like this: --- --- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) --- >>> 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 ( - -- * Building and using safe links - -- - -- | Note that 'URI' is Network.URI.URI from the network-uri package. - safeLink - , URI(..) - -- * Adding custom types - , HasLink(..) - , linkURI - , Link - , IsElem' - -- * Illustrative exports - , IsElem - , Or -) where - -import qualified Data.ByteString.Char8 as BSC -import Data.List -import Data.Monoid.Compat ( (<>) ) -import Data.Proxy ( Proxy(..) ) -import qualified Data.Text as Text -import GHC.Exts (Constraint) -import GHC.TypeLits ( KnownSymbol, symbolVal ) -import Network.URI ( URI(..), escapeURIString, isUnreserved ) -import Prelude () -import Prelude.Compat - -import Web.HttpApiData -import Servant.API.Capture ( Capture ) -import Servant.API.ReqBody ( ReqBody ) -import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) -import Servant.API.Header ( Header ) -import Servant.API.RemoteHost ( RemoteHost ) -import Servant.API.Verbs ( Verb ) -import Servant.API.Sub ( type (:>) ) -import Servant.API.Raw ( Raw ) -import Servant.API.Alternative ( type (:<|>) ) - --- | 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 :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"] - , _queryParams :: [Param Query] - } deriving Show - -instance ToHttpApiData Link where - toUrlPiece = Text.pack . show - toHeader = BSC.pack . show - --- | If either a or b produce an empty constraint, produce an empty constraint. -type family Or (a :: Constraint) (b :: Constraint) :: Constraint where - -- This works because of: - -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap - Or () b = () - Or a () = () - --- | If both a or b produce an empty constraint, produce an empty constraint. -type family And (a :: Constraint) (b :: Constraint) :: Constraint where - And () () = () - --- | You may use this type family to tell the type checker that your custom --- type may be skipped as part of a link. This is useful for things like --- 'QueryParam' that are optional in a URI and do not affect them if they are --- omitted. --- --- >>> data CustomThing --- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s --- --- Note that 'IsElem' is called, which will mutually recurse back to `IsElem'` --- if it exhausts all other options again. --- --- Once you have written a HasLink instance for CustomThing you are ready to --- go. -type family IsElem' a s :: Constraint - --- | Closed type family, check if endpoint is within api -type family IsElem endpoint api :: Constraint where - IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) - IsElem (e :> sa) (e :> sb) = IsElem sa sb - IsElem sa (Header sym x :> sb) = IsElem sa sb - IsElem sa (ReqBody y x :> sb) = IsElem sa sb - IsElem (Capture z y :> sa) (Capture x y :> sb) - = IsElem sa sb - IsElem sa (QueryParam x y :> sb) = IsElem sa sb - IsElem sa (QueryParams x y :> sb) = IsElem sa sb - IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem (Verb m s ct typ) (Verb m s ct' typ) - = IsSubList ct ct' - IsElem e e = () - IsElem e a = IsElem' e a - -type family IsSubList a b :: Constraint where - IsSubList '[] b = () - IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y - -type family Elem e es :: Constraint where - Elem x (x ': xs) = () - Elem y (x ': xs) = Elem y xs - --- Phantom types for Param -data Query - --- | Query param -data Param a - = SingleParam String Text.Text - | ArrayElemParam String Text.Text - | FlagParam String - deriving Show - -addSegment :: String -> Link -> Link -addSegment seg l = l { _segments = _segments l <> [seg] } - -addQueryParam :: Param Query -> Link -> Link -addQueryParam qp l = - l { _queryParams = _queryParams l <> [qp] } - -linkURI :: Link -> URI -linkURI (Link segments q_params) = - URI mempty -- No scheme (relative) - Nothing -- Or authority (relative) - (intercalate "/" segments) - (makeQueries q_params) mempty - where - makeQueries :: [Param Query] -> String - makeQueries [] = "" - makeQueries xs = - "?" <> intercalate "&" (fmap makeQuery xs) - - makeQuery :: Param Query -> String - makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (Text.unpack v) - makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) - makeQuery (FlagParam k) = escape k - -escape :: String -> String -escape = escapeURIString isUnreserved - --- | Create a valid (by construction) relative URI with query params. --- --- This function will only typecheck if `endpoint` is part of the API `api` -safeLink - :: forall endpoint api. (IsElem endpoint api, HasLink endpoint) - => Proxy api -- ^ The whole API that this endpoint is a part of - -> Proxy endpoint -- ^ The API endpoint you would like to point to - -> MkLink endpoint -safeLink _ endpoint = toLink endpoint (Link mempty mempty) - --- | Construct a toLink for an endpoint. -class HasLink endpoint where - type MkLink endpoint - toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to - -> Link - -> MkLink endpoint - --- Naked symbol instance -instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where - type MkLink (sym :> sub) = MkLink sub - toLink _ = - toLink (Proxy :: Proxy sub) . addSegment seg - where - seg = symbolVal (Proxy :: Proxy sym) - - --- QueryParam instances -instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) - => HasLink (QueryParam sym v :> sub) where - type MkLink (QueryParam sym v :> sub) = Maybe v -> MkLink sub - toLink _ l mv = - toLink (Proxy :: Proxy sub) $ - maybe id (addQueryParam . SingleParam k . toQueryParam) mv l - where - k :: String - k = symbolVal (Proxy :: Proxy sym) - -instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) - => HasLink (QueryParams sym v :> sub) where - type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub - toLink _ l = - toLink (Proxy :: Proxy sub) . - foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l - where - k = symbolVal (Proxy :: Proxy sym) - -instance (KnownSymbol sym, HasLink sub) - => HasLink (QueryFlag sym :> sub) where - type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub - toLink _ l False = - toLink (Proxy :: Proxy sub) l - toLink _ l True = - toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l - where - k = symbolVal (Proxy :: Proxy sym) - --- Misc instances -instance HasLink sub => HasLink (ReqBody ct a :> sub) where - type MkLink (ReqBody ct a :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) - -instance (ToHttpApiData v, HasLink sub) - => HasLink (Capture sym v :> sub) where - type MkLink (Capture sym v :> sub) = v -> MkLink sub - toLink _ l v = - toLink (Proxy :: Proxy sub) $ - addSegment (escape . Text.unpack $ toUrlPiece v) l - -instance HasLink sub => HasLink (Header sym a :> sub) where - type MkLink (Header sym a :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) - -instance HasLink sub => HasLink (RemoteHost :> sub) where - type MkLink (RemoteHost :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) - --- Verb (terminal) instances -instance HasLink (Verb m s ct a) where - type MkLink (Verb m s ct a) = URI - toLink _ = linkURI - -instance HasLink Raw where - type MkLink Raw = URI - toLink _ = linkURI diff --git a/test/Doctests.hs b/test/Doctests.hs deleted file mode 100644 --- a/test/Doctests.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Main where - -import Data.List (isPrefixOf) -import System.Directory -import System.FilePath -import System.FilePath.Find -import Test.DocTest - -main :: IO () -main = do - files <- find always (extension ==? ".hs") "src" - tfiles <- find always (extension ==? ".hs") "test/Servant" - mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : "-Iinclude" : - (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ - "-XOverloadedStrings" : - "-XFlexibleInstances" : - "-XMultiParamTypeClasses" : - (files ++ tfiles) - -getCabalMacrosFile :: IO (Maybe FilePath) -getCabalMacrosFile = do - exists <- doesDirectoryExist "dist" - if exists - then do - contents <- getDirectoryContents "dist" - let rest = "build" "autogen" "cabal_macros.h" - whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of - [x] -> "dist" x rest - [] -> "dist" rest - xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n" - ++ show xs ++ "\nTry cabal clean" - else return Nothing - where - whenExists :: FilePath -> IO (Maybe FilePath) - whenExists file = do - exists <- doesFileExist file - return $ if exists - then Just file - else Nothing 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,28 +8,34 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Monoid -#endif -import Control.Arrow -import Data.Aeson -import Data.ByteString.Char8 (ByteString, append, pack) -import qualified Data.ByteString.Lazy as BSL +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 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.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 Network.URL (exportParams, importParams) import Test.Hspec +import Network.HTTP.Media () -- for CPP import Test.QuickCheck -import "quickcheck-instances" Test.QuickCheck.Instances () +import "quickcheck-instances" Test.QuickCheck.Instances () +import Text.Read + (readMaybe) import Servant.API.ContentTypes @@ -69,20 +75,14 @@ it "has mimeUnrender reverse mimeRender for valid top-level json " $ do property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData) - describe "The FormUrlEncoded Content-Type type" $ do - let p = Proxy :: Proxy FormUrlEncoded - - it "has mimeUnrender reverse mimeRender" $ do - property $ \x -> mempty `notElem` x - ==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)]) + describe "The NoContent Content-Type type" $ do + let p = Proxy :: Proxy '[JSON] - it "has mimeUnrender reverse exportParams (Network.URL)" $ do - property $ \x -> mempty `notElem` x - ==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)]) + it "does not render any content" $ + allMimeRender p NoContent `shouldSatisfy` all (BSL8.null . snd) - it "has importParams (Network.URL) reverse mimeRender" $ do - property $ \x -> mempty `notElem` x - ==> (fmap (map (cs *** cs)) . importParams . cs . mimeRender p $ x) == Just (x::[(TextS.Text,TextS.Text)]) + it "evaluates the NoContent value" $ + evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall describe "The PlainText Content-Type type" $ do let p = Proxy :: Proxy PlainText @@ -119,31 +119,50 @@ "application/octet-stream" ("content" :: ByteString) `shouldSatisfy` isJust + it "returns Just if the 'Accept' header matches, with multiple mime types" $ do + handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int) + `shouldBe` Nothing + it "returns the Content-Type as the first element of the tuple" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) "application/octet-stream" ("content" :: ByteString) `shouldSatisfy` ((== "application/octet-stream") . fst . fromJust) it "returns the appropriately serialized representation" $ do property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData) - == Just ("application/json", encode x) + == 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", b) + , ("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 @@ -176,18 +195,32 @@ (encode val) `shouldBe` Just (Right val) -#if MIN_VERSION_aeson(0,9,0) - -- aeson >= 0.9 decodes top-level strings - describe "eitherDecodeLenient" $ do + it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do + let val = 42 :: Int + handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json" + "42" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain" + "42" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" + "42" `shouldBe` (Nothing :: Maybe (Either String Int)) - it "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 + it "passes content-type to mimeUnrenderWithType" $ do + let val = "foobar" :: TextS.Text + handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json" + "\"foobar\"" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain" + "foobar" `shouldBe` Just (Right val) + handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" + "foobar" `shouldBe` (Nothing :: Maybe (Either String Int)) + describe "eitherDecode is lenient" $ do + -- Since servant-0.20.1 MimeUnrender JSON instance uses eitherDecode, + -- as aeson >= 0.9 supports decoding top-level strings and numbers. + it "parses top-level strings" $ do + property $ \x -> mimeUnrender (Proxy :: Proxy JSON) x + `shouldBe` (eitherDecode x :: Either String String) + data SomeData = SomeData { record1 :: String, record2 :: Int } deriving (Generic, Eq, Show) @@ -205,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 ] @@ -219,8 +252,25 @@ instance IsString AcceptHeader where fromString = AcceptHeader . fromString +-- To test multiple content types +data JSONorText + +instance Accept JSONorText where + contentTypes _ = "text/plain" NE.:| [ "application/json" ] + +instance MimeRender JSONorText Int where + mimeRender _ = BSL8.pack . show + +instance MimeUnrender JSONorText Int where + mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack + +instance MimeUnrender JSONorText TextS.Text where + mimeUnrenderWithType _ mt + | mt == "application/json" = maybe (Left "") Right . decode + | otherwise = Right . TextSE.decodeUtf8 . BSL.toStrict + addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) - where new = 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 @@ -22,3 +30,20 @@ it "adds headers to the front of the list" $ do let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int getHeaders val `shouldBe` [("first", "10"), ("second", "b")] + + it "adds a header with description to a value" $ do + let val = addHeader' "hi" 5 :: Headers '[Header' '[Description "desc", Optional, Strict] "test" String] Int + getHeaders val `shouldBe` [("test", "hi")] + + describe "noHeader" $ do + + it "does not add a header" $ do + let val = noHeader 5 :: Headers '[Header "test" Int] Int + getHeaders val `shouldBe` [] + + describe "HasStatus Headers" $ do + + it "gets the status from the underlying value" $ do + natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204 + natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503 + 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/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs deleted file mode 100644 --- a/test/Servant/Utils/LinksSpec.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -module Servant.Utils.LinksSpec where - -import Data.Proxy (Proxy (..)) -import Test.Hspec (Expectation, Spec, describe, it, - shouldBe) - -import Servant.API - -type TestApi = - -- Capture and query params - "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] () - - -- Flags - :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] () - - -- All of the verbs - :<|> "get" :> Get '[JSON] () - :<|> "put" :> Put '[JSON] () - :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] () - :<|> "delete" :> Header "ponies" String :> Delete '[JSON] () - :<|> "raw" :> Raw - - -apiLink :: (IsElem endpoint TestApi, HasLink endpoint) - => Proxy endpoint -> MkLink endpoint -apiLink = safeLink (Proxy :: Proxy TestApi) - --- | Convert a link to a URI and ensure that this maps to the given string --- given string -shouldBeURI :: URI -> String -> Expectation -shouldBeURI link expected = - show link `shouldBe` 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] ()) - apiLink l1 "hi" `shouldBeURI` "hello/hi" - - let l2 = Proxy :: Proxy ("hello" :> Capture "name" String - :> QueryParam "capital" Bool - :> Delete '[JSON] ()) - apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true" - - - it "generates correct links for query flags" $ do - let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" - :> QueryFlag "fast" :> Delete '[JSON] ()) - apiLink l1 True True `shouldBeURI` "balls?bouncy&fast" - apiLink l1 False True `shouldBeURI` "balls?fast" - - it "generates correct links for all of the verbs" $ do - apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get" - apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put" - apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post" - apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete" - apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw" - - --- | --- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, --- we'll just use doctest --- --- >>> apiLink (Proxy :: Proxy WrongPath) --- ... --- ...Could not deduce... --- ... --- --- >>> apiLink (Proxy :: Proxy WrongReturnType) --- ... --- ...Could not deduce... --- ... --- --- >>> apiLink (Proxy :: Proxy WrongContentType) --- ... --- ...Could not deduce... --- ... --- --- >>> apiLink (Proxy :: Proxy WrongMethod) --- ... --- ...Could not deduce... --- ... --- --- >>> apiLink (Proxy :: Proxy NotALink) --- ... --- ...Could not deduce... --- ... --- --- sanity check --- >>> apiLink (Proxy :: Proxy AllGood) --- get -type WrongPath = "getTypo" :> Get '[JSON] () -type WrongReturnType = "get" :> Get '[JSON] Bool -type WrongContentType = "get" :> Get '[OctetStream] () -type WrongMethod = "get" :> Post '[JSON] () -type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool -type AllGood = "get" :> Get '[JSON] ()