servant-0.19.1/0000755000000000000000000000000007346545000011455 5ustar0000000000000000servant-0.19.1/CHANGELOG.md0000644000000000000000000011521707346545000013275 0ustar0000000000000000[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.19.1 ------ Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592). 0.19 ---- ### Significant changes - Drop support for GHC < 8.6. - Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). - Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) related to hash collisions. - Add `NamedRoutes` combinator, making support for records first-class in Servant ([#1388](https://github.com/haskell-servant/servant/pull/1388)). Users can now directly mark part as an API as defined by a record, instead of using `(:<|>)` to combine routes. Concretely, the anonymous: ```haskell type API = "version" :> Get '[JSON] String :<|> "products" :> Get '[JSON] [Product] ``` can be replaced with the explicitly-named: ```haskell type API = NamedRoutes NamedAPI data NamedAPI mode = NamedAPI { version :: mode :- "version" :> Get '[JSON] String , products :: mode :- "products" :> Get '[JSON] [Product] } ``` `NamedRoutes` builds upon `servant-generic`, but improves usability by freeing users from the need to perform `toServant` / `fromServant` conversions manually. Serving `NamedRoutes NamedAPI` is now done directly by providing a record of handlers, and servant generates clients directly as records as well. In particular, it makes it much more practical to work with nested hierarchies of named routes. Two convenience functions, `(//)` and `(/:)`, have been added to make the usage of named route hierarchies more pleasant: ```haskell rootClient :: RootApi (AsClientT ClientM) rootClient = client (Proxy @API) helloClient :: String -> ClientM String helloClient name = rootClient // hello /: name endpointClient :: ClientM Person endpointClient = rootClient // subApi /: "foobar123" // endpoint type Api = NamedRoutes RootApi data RootApi mode = RootApi { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi , hello :: mode :- Capture "name" String :> Get '[JSON] String , … } deriving Generic data SubApi mode = SubApi { endpoint :: mode :- Get '[JSON] Person , … } deriving Generic ``` - Add custom type errors for partially applied combinators ([#1289](https://github.com/haskell-servant/servant/pull/1289), [#1486](https://github.com/haskell-servant/servant/pull/1486)). For example, forgetting to document the expected type for a query parameter, as in: ``` haskell type API = QueryParam "param" :> Get '[JSON] NoContent ``` will raise to the following error when trying to serve the API: ``` • There is no instance for HasServer (QueryParam' '[Optional, Strict] "param" :> ...) QueryParam' '[Optional, Strict] "1" expects 1 more arguments ``` As a consequence of this change, unsaturated types are now forbidden before `(:>)`. - Add a `HeadNoContent` verb ([#1502](https://github.com/haskell-servant/servant/pull/1502)). - *servant-client* / *servant-client-core* / *servant-http-streams*: Fix erroneous behavior, where only 2XX status codes would be considered successful, irrelevant of the status parameter specified by the verb combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469)) - *servant-client* / *servant-client-core*: Fix `Show` instance for `Servant.Client.Core.Request`. - *servant-client* / *servant-client-core*: Allow passing arbitrary binary data in Query parameters. ([#1432](https://github.com/haskell-servant/servant/pull/1432)). - *servant-docs*: Generate sample cURL requests ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)). Breaking change: requires sample header values to be supplied with `headers`. ### Other changes - Various bit rotten cookbooks have been updated and re-introduced on [docs.servant.dev](https://docs.servant.dev). - Various version bumps. 0.18.3 ------ ### Significant changes - Add response header support to UVerb (#1420). - Use Capture Description if available (#1423). ### Other changes - Support GHC-9.0.1. - Bump `bytestring`, `attoparsec`, `hspec` and `singleton-bool` dependencies. 0.18.2 ------ ### Significant changes - Introduce `Fragment` combinator. - Fix `MimeRender` and `MimeUnrender` instances for `WithStatus`. 0.18.1 ------ ### Significant changes - Union verbs ### Other changes - Bump "tested-with" ghc versions - Allow newer dependencies 0.18 ---- ### Significant changes - Support for ghc8.8 (#1318, #1326, #1327) - Configurable error messages for automatic errors thrown by servant, like "no route" or "could not parse json body" (#1312, #1326, #1327) ### Other changes - Witness that a type-level natural number corresponds to a HTTP status code (#1310) - Improve haddocs (#1279) - Dependency management (#1269, #1293, #1286, #1287) 0.17 ---- ### Significant changes - Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) The `NoContent` API endpoints should now use `NoContentVerb` combinator. The API type changes are usually of the kind ```diff - :<|> PostNoContent '[JSON] NoContent + :<|> PostNoContent ``` i.e. one doesn't need to specify the content-type anymore. There is no content. - `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) You can specify a lenient capture as ```haskell :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET ``` which will make the capture always succeed. Handlers will be of the type `Either String CapturedType`, where `Left err` represents the possible parse failure. - *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255) The new member `makeClientRequest` of `ClientEnv` is used to create `http-client` `Request` from `servant-client-core` `Request`. This functionality can be used for example to set dynamic timeouts for each request. - *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262) Some APIs need query parameters rewriting, e.g. in order to support for multiple casing (camel, snake, etc) or something to that effect. This could be easily achieved by using WAI Middleware and modifying request's `Query`. But QueryParam, QueryParams and QueryFlag use `rawQueryString`. By using `queryString` rather then `rawQueryString` we can enable such rewritings. - *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263) We used `build-type: Custom`, but it's problematic e.g. for cross-compiling. The benefit is small, as the doctests can be run other ways too (though not so conveniently). - *servant* Remove deprecated modules [1268#](https://github.com/haskell-servant/servant/pull/1268) - `Servant.Utils.Links` is `Servant.Links` - `Servant.API.Internal.Test.ComprehensiveAPI` is `Servant.Test.ComprehensiveAPI` ### Other changes - *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204) For `Verb`s with response `Headers`, the implementation didn't check for the content-type of the response. Now it does. - *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241) Servant supports defining the same route multiple times with different content-types and result-types, but servant-docs was only documenting the first of copy of such duplicated routes. It now combines the documentation from all the copies. Unfortunately, it is not yet possible for the documentation to specify multiple status codes. - Add sponsorship button [#1190](https://github.com/haskell-servant/servant/pull/1190) [Well-Typed](https://www.well-typed.com/) is a consultancy which could help you with `servant` issues (See consultancies section on https://www.servant.dev/). - Try changelog-d for changelog management [#1230](https://github.com/haskell-servant/servant/pull/1230) Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details - CI and testing tweaks. [#1154](https://github.com/haskell-servant/servant/pull/1154) [#1157](https://github.com/haskell-servant/servant/pull/1157) [#1182](https://github.com/haskell-servant/servant/pull/1182) [#1214](https://github.com/haskell-servant/servant/pull/1214) [#1229](https://github.com/haskell-servant/servant/pull/1229) [#1233](https://github.com/haskell-servant/servant/pull/1233) [#1242](https://github.com/haskell-servant/servant/pull/1242) [#1247](https://github.com/haskell-servant/servant/pull/1247) [#1250](https://github.com/haskell-servant/servant/pull/1250) [#1258](https://github.com/haskell-servant/servant/pull/1258) We are experiencing some bitrotting of cookbook recipe dependencies, therefore some of them aren't build as part of our CI anymore. - New cookbook recipes [#1088](https://github.com/haskell-servant/servant/pull/1088) [#1171](https://github.com/haskell-servant/servant/pull/1171) [#1198](https://github.com/haskell-servant/servant/pull/1198) - [OIDC Recipe](#TODO) - [MySQL Recipe](#TODO) - *servant-jsaddle* Progress on servant-jsaddle [#1216](https://github.com/haskell-servant/servant/pull/1216) - *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194) - *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197) - *servant* Remove unused extensions from cabal file [#1201](https://github.com/haskell-servant/servant/pull/1201) - *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238) - Dependency upgrades [#1173](https://github.com/haskell-servant/servant/pull/1173) [#1181](https://github.com/haskell-servant/servant/pull/1181) [#1183](https://github.com/haskell-servant/servant/pull/1183) [#1188](https://github.com/haskell-servant/servant/pull/1188) [#1224](https://github.com/haskell-servant/servant/pull/1224) [#1245](https://github.com/haskell-servant/servant/pull/1245) [#1257](https://github.com/haskell-servant/servant/pull/1257) - Documentation updates [#1162](https://github.com/haskell-servant/servant/pull/1162) [#1174](https://github.com/haskell-servant/servant/pull/1174) [#1175](https://github.com/haskell-servant/servant/pull/1175) [#1234](https://github.com/haskell-servant/servant/pull/1234) [#1244](https://github.com/haskell-servant/servant/pull/1244) [#1247](https://github.com/haskell-servant/servant/pull/1247) 0.16.2 ------ * `singleton-bool-0.1.5` (`SBool` is re-exported) - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+) - Add `Show`, `Eq`, `Ord` `SBool b` instances. * dependencies update 0.16.1 ------ * Add `Semigroup` and `Monoid` `SourceT` instances [#1158](https://github.com/haskell-servant/servant/pull/1158) [#1159](https://github.com/haskell-servant/servant/pull/1159) * Use `http-api-data-0.4.1` [#1181](https://github.com/haskell-servant/servant/pull/1181) * Allow newer dependencies 0.16.0.1 -------- - Make tests work with `http-media-0.8` 0.16 ---- ### Significant changes - Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError` [#1131](https://github.com/haskell-servant/servant/pull/1131) - *servant-client-core* Rearrange modules. No more `Internal` modules, whole API is versioned. [#1130](https://github.com/haskell-servant/servant/pull/1130) - *servant-http-streams* New package [#1117](https://github.com/haskell-servant/servant/pull/1117) - *servant-client-core* `RequestBody` is now ```haskell = RequestBodyLBS LBS.ByteString | RequestBodyBS BS.ByteString | RequestBodySource (SourceIO LBS.ByteString) ``` i.e. no more replicates `http-client`s API. [#1117](https://github.com/haskell-servant/servant/pull/1117) - *servant-client-core* Keep structured exceptions in `ConnectionError` constructor of `ClientError` [#1115](https://github.com/haskell-servant/servant/pull/1115) ```diff -| ConnectionError Text +| ConnectionError SomeException ``` - *servant-client-core* Preserve failing request in `FailureResponse` constructor of `ClientError` [#1114](https://github.com/haskell-servant/servant/pull/1114) ```diff -FailureResponse Response +-- | The server returned an error response including the +-- failing request. 'requestPath' includes the 'BaseUrl' and the +-- path of the request. +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response ``` - *servant-client* Fix (implement) `StreamBody` instance [#1110](https://github.com/haskell-servant/servant/pull/1110) ### Other changes - *servant-client* Update CookieJar with intermediate request/responses (redirects) [#1104](https://github.com/haskell-servant/servant/pull/1104) - *servant-server* Reorder HTTP failure code priorities [#1103](https://github.com/haskell-servant/servant/pull/1103) - *servant-server* Re-organise internal modules [#1139](https://github.com/haskell-servant/servant/pull/1139) - Allow `network-3.0` [#1107](https://github.com/haskell-servant/servant/pull/1107) - Add `NFData NoContent` instance [#1090](https://github.com/haskell-servant/servant/pull/1090) - Documentation updates [#1127](https://github.com/haskell-servant/servant/pull/1127) [#1124](https://github.com/haskell-servant/servant/pull/1124) [#1098](https://github.com/haskell-servant/servant/pull/1098) - CI updates [#1123](https://github.com/haskell-servant/servant/pull/1123) [#1121](https://github.com/haskell-servant/servant/pull/1121) [#1119](https://github.com/haskell-servant/servant/pull/1119) 0.15 ---- ### Significant changes - Streaming refactoring. [#991](https://github.com/haskell-servant/servant/pull/991) [#1076](https://github.com/haskell-servant/servant/pull/1076) [#1077](https://github.com/haskell-servant/servant/pull/1077) The streaming functionality (`Servant.API.Stream`) is refactored to use `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), which replaces both `StreamGenerator` and `ResultStream` types. New conversion type-classes are `ToSourceIO` and `FromSourceIO` (replacing `ToStreamGenerator` and `BuildFromStream`). There are instances for *conduit*, *pipes* and *machines* in new packages: [servant-conduit](https://hackage.haskell.org/package/servant-conduit) [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and [servant-machines](https://hackage.haskell.org/package/servant-machines) respectively. Writing new framing strategies is simpler. Check existing strategies for examples. This change shouldn't affect you, if you don't use streaming endpoints. - *servant-client* Separate streaming client. [#1066](https://github.com/haskell-servant/servant/pull/1066) We now have two `http-client` based clients, in `Servant.Client` and `Servant.Client.Streaming`. Their API is the same, except for - `Servant.Client` **cannot** request `Stream` endpoints. - `Servant.Client` is *run* by direct `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)` - `Servant.Client.Streaming` **can** request `Stream` endpoints. - `Servant.Client.Streaming` is *used* by CPSised `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b` To access `Stream` endpoints use `Servant.Client.Streaming` with `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`. You can use both too, `ClientEnv` and `BaseUrl` types are same for both. **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints. Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until the whole response is received. There is `Servant.Client.Streaming.runClientM` function, but it has restricted type. `NFData a` constraint prevents using it with `SourceT`, `Conduit` etc. response types. ```haskell runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) ``` This change shouldn't affect you, if you don't use streaming endpoints. - *servant-client-core* Related to the previous: `streamingResponse` is removed from `RunClient`. We have a new type-class: ```haskell class RunClient m => RunStreamingClient m where withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a ``` - Drop support for GHC older than 8.0 [#1008](https://github.com/haskell-servant/servant/pull/1008) [#1009](https://github.com/haskell-servant/servant/pull/1009) - *servant* `ComprehensiveAPI` is a part of public API in `Servant.Test.ComprehensiveAPI` module. This API type is used to verify that libraries implement all core combinators. Now we won't change this type between major versions. (This has been true for some time already). [#1070](https://github.com/haskell-servant/servant/pull/1070) - *servant* Remove `Servant.Utils.Enter` module (deprecated in `servant-0.12` in favour of `hoistServer`) [#996](https://github.com/haskell-servant/servant/pull/996) - *servant-foreign* Add support so `HasForeign` can be implemented for `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart) [#1035](https://github.com/haskell-servant/servant/pull/1035) ### Other changes - *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances. [#1076](https://github.com/haskell-servant/servant/pull/1076) - *servant* NewlineFraming encodes newline after each element (i.e last) [#1079](https://github.com/haskell-servant/servant/pull/1079) [#1011](https://github.com/haskell-servant/servant/issues/1011) - *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a` [#1064](https://github.com/haskell-servant/servant/pull/1064) - *servant-server* Add `MonadMask Handler` [#1068](https://github.com/haskell-servant/servant/pull/1068) - *servant-docs* Fix markdown indentation [#1043](https://github.com/haskell-servant/servant/pull/1043) - *servant* Export `GetHeaders'` [#1052](https://github.com/haskell-servant/servant/pull/1052) - *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>` [#1032](https://github.com/haskell-servant/servant/pull/1032) - *servant* Add `PutCreated` method type alias [#1024](https://github.com/haskell-servant/servant/pull/1024) - *servant-client-core* Add `aeson` and `Lift BaseUrl` instances [#1037](https://github.com/haskell-servant/servant/pull/1037) - *servant* Add `ToSourceIO (NonEmpty a)` instance [#988](https://github.com/haskell-servant/servant/pull/988) - Development process improvements - Apply `stylish-haskell` to all modules [#1001](https://github.com/haskell-servant/servant/pull/1001) - Amend `CONTRIBUTING.md` [#1036](https://github.com/haskell-servant/servant/pull/1036) - `servant-docs` has golden tests for `ComprehensiveAPI` [#1071](https://github.com/haskell-servant/servant/pull/1071) - Other [#1039](https://github.com/haskell-servant/servant/pull/1039) [#1046](https://github.com/haskell-servant/servant/pull/1046) [#1062](https://github.com/haskell-servant/servant/pull/1062) [#1069](https://github.com/haskell-servant/servant/pull/1069) [#985](https://github.com/haskell-servant/servant/pull/985) - *Documentation* Tutorial and new recipes - [Using free client](https://docs.servant.dev/en/latest/cookbook/using-free-client/UsingFreeClient.html) [#1005](https://github.com/haskell-servant/servant/pull/1005) - [Generating mock curl calls](https://docs.servant.dev/en/latest/cookbook/curl-mock/CurlMock.html) [#1033](https://github.com/haskell-servant/servant/pull/1033) - [Error logging with Sentry](https://docs.servant.dev/en/latest/cookbook/sentry/Sentry.html) [#987](https://github.com/haskell-servant/servant/pull/987) - [Hoist Server With Context for Custom Monads](https://docs.servant.dev/en/latest/cookbook/hoist-server-with-context/HoistServerWithContext.html) [#1044](https://github.com/haskell-servant/servant/pull/1044) - [How To Test Servant Applications](https://docs.servant.dev/en/latest/cookbook/testing/Testing.html) [#1050](https://github.com/haskell-servant/servant/pull/1050) - `genericServeT`: using custom monad with `Servant.API.Generic` in [Using generics](https://docs.servant.dev/en/latest/cookbook/generic/Generic.html) [#1058](https://github.com/haskell-servant/servant/pull/1058) - Tutorial [#974](https://github.com/haskell-servant/servant/pull/974) [#1007](https://github.com/haskell-servant/servant/pull/1007) - miscellanea: fixed typos etc. [#1030](https://github.com/haskell-servant/servant/pull/1030) [#1020](https://github.com/haskell-servant/servant/pull/1020) [#1059](https://github.com/haskell-servant/servant/pull/1059) - *Documentation* README [#1010](https://github.com/haskell-servant/servant/pull/1010) - *servant-client-ghcjs* updates. **note** package is not released on Hackage [#938](https://github.com/haskell-servant/servant/pull/938) 0.14.1 ------ - Merge in (and slightly refactor) `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick)) into `servant` (`Servant.API.Generic`), `servant-client-code` (`Servant.Client.Generic`) and `servant-server` (`Servant.Server.Generic`). - Deprecate `Servant.Utils.Links`, use `Servant.Links`. [#998](https://github.com/haskell-servant/servant/pull/998) - *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`. 0.14 ---- ### Significant changes - `Stream` takes a status code argument ```diff -Stream method framing ctype a +Stream method status framing ctype a ``` ([#966](https://github.com/haskell-servant/servant/pull/966) [#972](https://github.com/haskell-servant/servant/pull/972)) - `ToStreamGenerator` definition changed, so it's possible to write an instance for conduits. ```diff -class ToStreamGenerator f a where - toStreamGenerator :: f a -> StreamGenerator a +class ToStreamGenerator a b | a -> b where + toStreamGenerator :: a -> StreamGenerator b ``` ([#959](https://github.com/haskell-servant/servant/pull/959)) - Added `NoFraming` streaming strategy ([#959](https://github.com/haskell-servant/servant/pull/959)) - *servant-client-core* Free `Client` implementation. Useful for testing `HasClient` instances. ([#920](https://github.com/haskell-servant/servant/pull/920)) - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers of a web application live, we also have `hoistClient` for changing the monad in which *client functions* live. Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) iF you have own combinators, you'll need to define a new method of `HasClient` class, for example: ```haskell type Client m (MyCombinator :> api) = MyValue :> Client m api hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl ``` - *servant* Add `safeLink' :: (Link -> a) -> ... -> MkLink endpoint a`, which allows to create helpers returning something else than `Link`. ([#968](https://github.com/haskell-servant/servant/pull/968)) - *servant-server* File serving in polymorphic monad. i.e. Generalised types of `serveDirectoryFileServer` etc functions in `Servant.Utils.StaticFiles` ([#953](https://github.com/haskell-servant/servant/pull/953)) - *servant-server* `ReqBody` content type check is recoverable. This allows writing APIs like: ```haskell ReqBody '[JSON] Int :> Post '[PlainText] Int :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int ``` which is useful when handlers are subtly different, for example may do less work. ([#937](https://github.com/haskell-servant/servant/pull/937)) - *servant-client* Add more constructors to `RequestBody`, including `RequestBodyStream`. *Note:* we are looking for http-library agnostic API, so the might change again soon. Tell us which constructors are useful for you! ([#913](https://github.com/haskell-servant/servant/pull/913)) ### Other changes - `GetHeaders` instances implemented without `OverlappingInstances` ([#971](https://github.com/haskell-servant/servant/pull/971)) - Added tests or enabled tests ([#975](https://github.com/haskell-servant/servant/pull/975)) - Add [pagination cookbook recipe](https://docs.servant.dev/en/release-0.14/cookbook/pagination/Pagination.html) ([#946](https://github.com/haskell-servant/servant/pull/946)) - Add [`servant-flatten` "spice" to the structuring api recipe](https://docs.servant.dev/en/release-0.14/cookbook/structuring-apis/StructuringApis.html) ([#929](https://github.com/haskell-servant/servant/pull/929)) - Dependency updates ([#900](https://github.com/haskell-servant/servant/pull/900) [#919](https://github.com/haskell-servant/servant/pull/919) [#924](https://github.com/haskell-servant/servant/pull/924) [#943](https://github.com/haskell-servant/servant/pull/943) [#964](https://github.com/haskell-servant/servant/pull/964) [#967](https://github.com/haskell-servant/servant/pull/967) [#976](https://github.com/haskell-servant/servant/pull/976)) - Documentation updates [#963](https://github.com/haskell-servant/servant/pull/963) [#960](https://github.com/haskell-servant/servant/pull/960) [#908](https://github.com/haskell-servant/servant/pull/908) [#958](https://github.com/haskell-servant/servant/pull/958) [#948](https://github.com/haskell-servant/servant/pull/948) [#928](https://github.com/haskell-servant/servant/pull/928) [#921](https://github.com/haskell-servant/servant/pull/921)) - Development process improvements ([#680](https://github.com/haskell-servant/servant/pull/680) [#917](https://github.com/haskell-servant/servant/pull/917) [#923](https://github.com/haskell-servant/servant/pull/923) [#961](https://github.com/haskell-servant/servant/pull/961) [#973](https://github.com/haskell-servant/servant/pull/973)) ### Note (VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant\/pull\/\1)/` 0.13.0.1 -------- - Support `base-compat-0.10` 0.13 ---- ### Significant changes - Streaming endpoint support. ([#836](https://github.com/haskell-servant/servant/pull/836)) ```haskell type StreamApi f = "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) ``` See tutorial for more details - [A web API as a type - StreamGet and StreamPost](http://docs.servant.dev/en/release-0.13/tutorial/ApiType.html#streamget-and-streampost) - [Serving an API - streaming endpoints](http://docs.servant.dev/en/release-0.13/tutorial/Server.html#streaming-endpoints) - [Querying an API - Querying Streaming APIs](http://docs.servant.dev/en/release-0.13/tutorial/Client.html#querying-streaming-apis) - *servant* Add `Servant.API.Modifiers` ([#873](https://github.com/haskell-servant/servant/pull/873) [#903](https://github.com/haskell-servant/servant/pull/903)) `QueryParam`, `Header` and `ReqBody` understand modifiers: - `Required` or `Optional` (resulting in `a` or `Maybe a` in handlers) - `Strict` or `Lenient` (resulting in `a` or `Either String a` in handlers) Also you can use `Description` as a modifier, but it doesn't yet work with `servant-docs`, only `servant-swagger`. [There is an issue.](https://github.com/haskell-servant/servant/issues/902) - *servant-client* Support `http-client`’s `CookieJar` ([#897](https://github.com/haskell-servant/servant/pull/897) [#883](https://github.com/haskell-servant/servant/pull/883)) `ClientM` preserves cookies between requests, if given initial `CookieJar`. To migrate from older code, change `ClientEnv` constructor to `mkClientEnv` which makes `ClientEnv` without `CookieJar`. - *servant* Mono-kind-ise modifiers, resulting in better error messages. ([#887](https://github.com/haskell-servant/servant/issues/887) [#890](https://github.com/haskell-servant/servant/pull/890)) - *servant* Add `TypeError ... => HasServer`s instances in GHC-8.2 for not saturated modifiers (`Capture "foo" :> ...`) or `->` in place of `:>`. ([#893](https://github.com/haskell-servant/servant/pull/893)) - *Cookbook* example projects at http://docs.servant.dev/en/master/cookbook/index.html ([#867](https://github.com/haskell-servant/servant/pull/867) [#892](https://github.com/haskell-servant/servant/pull/882)) - *Experimental work* `servant-client-ghcjs` ([#818](https://github.com/haskell-servant/servant/pull/818) [#869](https://github.com/haskell-servant/servant/pull/869)) ### Other changes - *servant* Links aren't double escaped ([#878](https://github.com/haskell-servant/servant/pull/878)) - Dependency updates ([#900](https://github.com/haskell-servant/servant/pull/900) [#898](https://github.com/haskell-servant/servant/pull/898) [#895](https://github.com/haskell-servant/servant/pull/895) [#872](https://github.com/haskell-servant/servant/pull/872)) - Documentation updates ([#875](https://github.com/haskell-servant/servant/pull/875) [#861](https://github.com/haskell-servant/servant/pull/861)) - Refactorings ([#899](https://github.com/haskell-servant/servant/pull/899) [#896](https://github.com/haskell-servant/servant/pull/896) [#889](https://github.com/haskell-servant/servant/pull/889) [#891](https://github.com/haskell-servant/servant/pull/891) [#892](https://github.com/haskell-servant/servant/pull/892) [#885](https://github.com/haskell-servant/servant/pull/885)) 0.12.1 ------ ### Bug fixes - Prevent double-escaping in link segments ([#835](https://github.com/haskell-servant/servant/issues/835) [#878](https://github.com/haskell-servant/servant/pull/878)) 0.12 --- ### Significant changes - *servant-client* *servant-client-core* Factored out of `servant-client` all the functionality that was independent of the `http-client` backend. ([#803](https://github.com/haskell-servant/servant/pull/803) [#821](https://github.com/haskell-servant/servant/issues/821)) If you have own combinators, you'll need to add an additional `m` argument in `HasClient`, `Client` and `clientWithRoute`: ```diff -class HasClient api - type Client (api :: *) :: * - clientWithRoute :: Proxy api -> Req -> Client api +class HasClient m api + type Client (m :: * -> *) (api :: *) :: * + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api ``` See https://github.com/haskell-servant/servant-auth/pull/67/commits/f777818e3cc0fa3ed2346baff8328e96d62b1790 for a real world example. - *servant-server* Added `hoistServer` member to the `HasServer` class, which is `HasServer` specific `enter`. ([#804](https://github.com/haskell-servant/servant/pull/804) [#824](https://github.com/haskell-servant/servant/pull/824)) `enter` isn't exported from `Servant` module anymore. You can change `enter` to `hoistServer` in a straight forward way. Unwrap natural transformation and add an api type `Proxy`: ```diff -server = enter (NT nt) impl +server = hoistServer (Proxy :: Proxy MyApi) nt impl ``` If you have own combinators, you'll need to define a new method of `HasServer` class, for example: ```haskell type ServerT (MyCombinator :> api) m = MyValue -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s ``` See https://github.com/haskell-servant/servant-auth/pull/67/commits/8ee3b6315247ac076516213fd7cfcdbfdb583ac9 for a real world example. - Add `Description` and `Summary` combinators ([#767](https://github.com/haskell-servant/servant/pull/767)) It's possible to annotate endpoints with free form text. This information is used by e.g. by `servant-swagger`, see screenshot in https://github.com/phadej/servant-swagger-ui - Lower `:>` and `:<|>` infix precedence to 4 and 3 respectively ([#761](https://github.com/haskell-servant/servant/issues/761)) This shouldn't affect you, except if you define your own infix operators for Servant type-level DSL. ### Other changes - *servant-foreign* Derive `Data` for all types ([#809](https://github.com/haskell-servant/servant/pull/809)) - *servant-docs* Add authentication lenses ([#787](https://github.com/haskell-servant/servant/pull/787)) - *servant-docs* Generated markdown improvements ([#813](https://github.com/haskell-servant/servant/pull/787) [#767](https://github.com/haskell-servant/servant/pull/767) [#790](https://github.com/haskell-servant/servant/pull/790) [#788](https://github.com/haskell-servant/servant/pull/788)) - Add `addLinks` to generate all links for unnested APIs. ([#851](https://github.com/haskell-servant/servant/pull/851)) - Allow newest dependencies ([#772](https://github.com/haskell-servant/servant/pull/772) [#842](https://github.com/haskell-servant/servant/pull/842)) - Documentation improvements and typo fixes ([#757](https://github.com/haskell-servant/servant/pull/757) [#771](https://github.com/haskell-servant/servant/pull/771) [#775](https://github.com/haskell-servant/servant/pull/775) [#790](https://github.com/haskell-servant/servant/pull/790) [#791](https://github.com/haskell-servant/servant/pull/791) [#806](https://github.com/haskell-servant/servant/pull/806)) - Development process improvements ([#764](https://github.com/haskell-servant/servant/pull/764) [#839](https://github.com/haskell-servant/servant/pull/839)) 0.11 ---- ### Breaking changes - `Enter` refactored ([#734](https://github.com/haskell-servant/servant/issues/734) , [#736](https://github.com/haskell-servant/servant/pull/736)) ### Other changes - Add a type representing an empty API ([#753](https://github.com/haskell-servant/servant/pull/753)) - Add `linkURI'` and `Link` accessors ([#745](https://github.com/haskell-servant/servant/pull/745) , [#717](https://github.com/haskell-servant/servant/pull/717) , [#715](https://github.com/haskell-servant/servant/issues/715)) - Prepare for GHC-8.2 ([#722](https://github.com/haskell-servant/servant/pull/722)) - Add `HasLink AuthProtect` instance ([#720](https://github.com/haskell-servant/servant/pull/720)) - `AllCTRender [] ()` `TypeError` (use `NoContent`) ([#671](https://github.com/haskell-servant/servant/pull/671)) - Documentation improvements and typo fixes ([#702](https://github.com/haskell-servant/servant/pull/702) , [#709](https://github.com/haskell-servant/servant/pull/709) , [#716](https://github.com/haskell-servant/servant/pull/716) , [#725](https://github.com/haskell-servant/servant/pull/725) , [#727](https://github.com/haskell-servant/servant/pull/727)) 0.10 ---- ### Breaking changes * Use `NT` from `natural-transformation` for `Enter` ([#616](https://github.com/haskell-servant/servant/issues/616)) * Change to `MkLink (Verb ...) = Link` (previously `URI`). To consume `Link` use its `ToHttpApiData` instance or `linkURI`. ([#527](https://github.com/haskell-servant/servant/issues/527)) ### Other changes * Add `Servant.API.TypeLevel` module with type families to work with API types. ([#345](https://github.com/haskell-servant/servant/pull/345) , [#305](https://github.com/haskell-servant/servant/issues/305)) * Default JSON content type change to `application/json;charset=utf-8`. ([#263](https://github.com/haskell-servant/servant/issues/263)) Related browser bugs: [Chromium](https://bugs.chromium.org/p/chromium/issues/detail?id=438464) and [Firefox](https://bugzilla.mozilla.org/show_bug.cgi?id=918742) * `Accept` class may accept multiple content-types. `MimeUnrender` adopted as well. ([#613](https://github.com/haskell-servant/servant/pull/614) , [#615](https://github.com/haskell-servant/servant/pull/615)) 0.9.1 ------ * Added 'noHeader' function for *not* adding response headers. 0.9 --- * Added Eq, Show, Read, Generic and Ord instances to IsSecure * BACKWARDS INCOMPATIBLE: replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo` * BACKWARDS INCOMPATIBLE: Moved `From/ToFormUrlEncoded` classes, which were renamed to `From/ToForm` to `http-api-data` 0.8.1 ---- * Add `CaptureAll` combinator. Captures all of the remaining segments in a URL. * Add `Servant.API.TypeLevel` module, with frequently used type-level functionaliy. 0.8 --- * Minor fixes, documentation changes and cabal tweaks 0.7.1 ----- * Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478) * Allow to set the same header multiple times in responses. 0.5 --- * Add `WithNamedConfig` combinator. * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Fix safeLink, so Header is not in fact required. * Add more instances for (:<|>) * Use `http-api-data` instead of `Servant.Common.Text` * Remove matrix params. * Add PlainText String MimeRender and MimeUnrender instances. * Add new `Verbs` combinator, and make all existing and new verb combinators type synonyms of it. * Add `BasicAuth` combinator to support Basic authentication * Add generalized authentication support 0.4.2 ----- * Fix missing cases for `Patch` in `safeLink` 0.4.1 ----- * Allow whitespace after parsing JSON * Stricter matching for `safeLink` for `Capture` 0.4 --- * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * Multiple content-type/accept support for all the relevant combinators * Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box * Type-safe link generation to API endpoints * Support for the PATCH HTTP method * Removed the home-made QuasiQuote for writing API types in a more human-friendly format until we come up with a better design for it * Make most if not all of the haddock code examples run through doctest * Some general code cleanup * Add response headers servant-0.19.1/LICENSE0000644000000000000000000000307307346545000012465 0ustar0000000000000000Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors 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 Zalora South East Asia Pte Ltd nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. 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. servant-0.19.1/Setup.hs0000644000000000000000000000007007346545000013106 0ustar0000000000000000import Distribution.Simple main = defaultMain servant-0.19.1/servant.cabal0000644000000000000000000001237707346545000014135 0ustar0000000000000000cabal-version: 2.2 name: servant version: 0.19.1 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 . . 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 ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 , GHCJS ==8.6.0.1 extra-source-files: CHANGELOG.md source-repository head type: git location: http://github.com/haskell-servant/servant.git library 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.HttpVersion Servant.API.IsSecure Servant.API.Modifiers Servant.API.NamedRoutes Servant.API.QueryParam Servant.API.Raw Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Status Servant.API.Stream Servant.API.Sub Servant.API.TypeErrors Servant.API.TypeLevel Servant.API.UVerb Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext -- Types exposed-modules: Servant.Types.SourceT -- 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.9 && < 4.18 , bytestring >= 0.10.8.1 && < 0.12 , constraints >= 0.2 , mtl >= 2.2.2 && < 2.3 , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6 , text >= 1.2.3.0 && < 2.1 -- 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.5.1 , singleton-bool >= 0.1.4 && < 0.1.7 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.13 , aeson >= 1.4.1.0 && < 3 , attoparsec >= 0.13.2.2 && < 0.15 , bifunctors >= 5.5.3 && < 5.6 , case-insensitive >= 1.2.0.11 && < 1.3 , deepseq >= 1.4.2.0 && < 1.5 , 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.15 , string-conversions >= 0.4.0.1 && < 0.5 , tagged >= 0.8.6 && < 0.9 , vault >= 0.3.1.2 && < 0.4 hs-source-dirs: src default-language: Haskell2010 other-extensions: AllowAmbiguousTypes , CPP , ConstraintKinds , DataKinds , DeriveDataTypeable , DeriveGeneric , ExplicitNamespaces , FlexibleContexts , FlexibleInstances , FunctionalDependencies , GADTs , KindSignatures , MultiParamTypeClasses , OverloadedStrings , PolyKinds , RankNTypes , ScopedTypeVariables , TupleSections , TypeFamilies , TypeOperators , UndecidableInstances ghc-options: -Wall -Wno-redundant-constraints test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs other-modules: Servant.API.ContentTypesSpec Servant.API.ResponseHeadersSpec Servant.API.StreamSpec Servant.LinksSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: base , base-compat , aeson , bytestring , http-media , mtl , servant , string-conversions , text , transformers -- Additional dependencies build-depends: hspec >= 2.6.0 && < 2.10 , QuickCheck >= 2.12.6.1 && < 2.15 , quickcheck-instances >= 0.3.19 && < 0.4 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && < 2.10 servant-0.19.1/src/Servant/0000755000000000000000000000000007346545000013666 5ustar0000000000000000servant-0.19.1/src/Servant/API.hs0000644000000000000000000001376207346545000014644 0ustar0000000000000000module Servant.API ( -- * Combinators module Servant.API.Sub, -- | Type-level combinator for expressing subrouting: @':>'@ module Servant.API.Alternative, -- | Type-level combinator for alternative endpoints: @':<|>'@ module Servant.API.Empty, -- | Type-level combinator for an empty API: @'EmptyAPI'@ module Servant.API.Modifiers, -- | Type-level modifiers for 'QueryParam', 'Header' and 'ReqBody'. -- * Accessing information from the request module Servant.API.Capture, -- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@ module Servant.API.Header, -- | 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.Fragment, -- | Documenting the fragment of the 'URI': @'Fragment'@ module Servant.API.ReqBody, -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ module Servant.API.RemoteHost, -- | Retrieving the IP of the client module Servant.API.IsSecure, -- | Is the request made through HTTPS? module Servant.API.Vault, -- | Access the location for arbitrary data to be shared by applications and middleware module Servant.API.WithNamedContext, -- | Access context entries in combinators in servant-server -- * 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, -- * Authentication module Servant.API.BasicAuth, -- * Endpoints description module Servant.API.Description, -- * Content Types module Servant.API.ContentTypes, -- | Serializing and deserializing types based on @Accept@ and -- @Content-Type@ headers. -- * Response Headers module Servant.API.ResponseHeaders, -- * Untyped endpoints module Servant.API.Raw, -- | Plugging in a wai 'Network.Wai.Application', serving directories -- * FromHttpApiData and ToHttpApiData module Web.HttpApiData, -- | Classes and instances for types that can be converted to and from HTTP API data. -- * Experimental modules module Servant.API.Experimental.Auth, -- | General Authentication -- * Links module Servant.Links, -- | Type-safe internal URIs -- * Re-exports If, SBool (..), SBoolI (..) ) where import Data.Singletons.Bool (SBool (..), SBoolI (..)) import Data.Type.Bool (If) import Servant.API.Alternative ((:<|>) (..)) import Servant.API.BasicAuth (BasicAuth, BasicAuthData (..)) import Servant.API.Capture (Capture, Capture', CaptureAll) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, JSON, MimeRender (..), MimeUnrender (..), NoContent (NoContent), OctetStream, PlainText) import Servant.API.Description (Description, Summary) import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Fragment (Fragment) import Servant.API.Header (Header, Header') import Servant.API.Generic (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct, GenericServant, fromServant, toServant, genericApi) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) import Servant.API.Modifiers (Lenient, Optional, Required, Strict) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) import Servant.API.Raw (Raw) 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, getHeadersHList, getResponse, lookupResponseHeader, noHeader) 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.NamedRoutes (NamedRoutes) 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.Links (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) servant-0.19.1/src/Servant/API/0000755000000000000000000000000007346545000014277 5ustar0000000000000000servant-0.19.1/src/Servant/API/Alternative.hs0000644000000000000000000000357607346545000017124 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where import Control.Applicative (liftA2) import Data.Biapplicative (Biapplicative (..)) import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..)) import Data.Bitraversable (Bitraversable (..)) import Data.Typeable (Typeable) import Prelude () import Prelude.Compat -- | Union of two APIs, first takes precedence in case of overlap. -- -- Example: -- -- >>> :{ --type MyApi = "books" :> Get '[JSON] [Book] -- GET /books -- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books -- :} data a :<|> b = a :<|> b deriving (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 -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.19.1/src/Servant/API/BasicAuth.hs0000644000000000000000000000237507346545000016505 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} module Servant.API.BasicAuth where import Data.ByteString (ByteString) import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) -- | Combinator for . -- -- *IMPORTANT*: Only use Basic Auth over HTTPS! Credentials are not hashed or -- encrypted. Note also that because the same credentials are sent on every -- request, Basic Auth is not as secure as some alternatives. Further, the -- implementation in servant-server does not protect against some types of -- timing attacks. -- -- In Basic Auth, username and password are base64-encoded and transmitted via -- the @Authorization@ header. Handshakes are not required, making it -- relatively efficient. data BasicAuth (realm :: Symbol) (userData :: *) deriving (Typeable) -- | A simple datatype to hold data required to decorate a request data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString , basicAuthPassword :: !ByteString } servant-0.19.1/src/Servant/API/Capture.hs0000644000000000000000000000232207346545000016235 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Capture (Capture, Capture', CaptureAll) where import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) -- | Capture a value from the request path under a certain type @a@. -- -- Example: -- -- >>> -- GET /books/:isbn -- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book type Capture = Capture' '[] -- todo -- | 'Capture' which can be modified. For example with 'Description'. data Capture' (mods :: [*]) (sym :: Symbol) (a :: *) 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 :: *) 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 } servant-0.19.1/src/Servant/API/ContentTypes.hs0000644000000000000000000003562507346545000017305 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from -- a particular Content-Type. -- -- Content-Types are used in `ReqBody` and the method combinators: -- -- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Put '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@ -- or @text/plain;charset-utf8@, and returns data in either one of those -- formats (depending on the @Accept@ header). -- -- If you would like to support Content-Types beyond those provided here, -- then: -- -- (1) Declare a new data type with no constructors (e.g. @data HTML@). -- (2) Make an instance of it for `Accept`. -- (3) If you want to be able to serialize data *into* that -- Content-Type, make an instance of it for `MimeRender`. -- (4) If you want to be able to deserialize data *from* that -- Content-Type, make an instance of it for `MimeUnrender`. -- -- Note that roles are reversed in @servant-server@ and @servant-client@: -- to be able to serve (or even typecheck) a @Get '[JSON, XML] MyData@, -- you'll need to have the appropriate `MimeRender` instances in scope, -- whereas to query that endpoint with @servant-client@, you'll need -- a `MimeUnrender` instance in scope. module Servant.API.ContentTypes ( -- * Provided Content-Types JSON , PlainText , FormUrlEncoded , OctetStream -- * Building your own Content-Type , Accept(..) , MimeRender(..) , MimeUnrender(..) -- * NoContent , NoContent(..) -- * Internal , AcceptHeader(..) , AllCTRender(..) , AllCTUnrender(..) , AllMime(..) , AllMimeRender(..) , AllMimeUnrender(..) , eitherDecodeLenient , canHandleAcceptH ) where import Control.Arrow (left) import Control.Monad.Compat import Control.DeepSeq (NFData) import Data.Aeson (FromJSON (..), ToJSON (..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, skipSpace, ()) import qualified Data.ByteString as BS import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) import Data.String.Conversions (cs) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable import GHC.Generics (Generic) import qualified GHC.TypeLits as TL import qualified Network.HTTP.Media as M import 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 -- * Accept class -- | Instances of 'Accept' represent mimetypes. They are used for matching -- against the @Accept@ HTTP header of the request, and for setting the -- @Content-Type@ header of the response -- -- Example: -- -- >>> import Network.HTTP.Media ((//), (/:)) -- >>> data HTML -- >>> :{ --instance Accept HTML where -- contentType _ = "text" // "html" /: ("charset", "utf-8") -- :} -- class Accept ctype where contentType :: Proxy ctype -> M.MediaType contentType = NE.head . contentTypes contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType contentTypes = (NE.:| []) . contentType {-# MINIMAL contentType | contentTypes #-} -- | @application/json@ instance Accept JSON where contentTypes _ = "application" M.// "json" M./: ("charset", "utf-8") NE.:| [ "application" M.// "json" ] -- | @application/x-www-form-urlencoded@ instance Accept FormUrlEncoded where contentType _ = "application" M.// "x-www-form-urlencoded" -- | @text/plain;charset=utf-8@ instance Accept PlainText where contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") -- | @application/octet-stream@ instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" newtype AcceptHeader = AcceptHeader BS.ByteString deriving (Eq, Show, Read, Typeable, Generic) -- * Render (serializing) -- | Instantiate this class to register a way of serializing a type based -- on the @Accept@ header. -- -- Example: -- -- > data MyContentType -- > -- > instance Accept MyContentType where -- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") -- > -- > instance Show a => MimeRender MyContentType a where -- > mimeRender _ val = pack ("This is MINE! " ++ show val) -- > -- > type MyAPI = "path" :> Get '[MyContentType] Int -- class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString class (AllMime list) => AllCTRender (list :: [*]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) instance {-# OVERLAPPABLE #-} (Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTRender '[] () where handleAcceptH _ _ _ = error "unreachable" -------------------------------------------------------------------------- -- * Unrender -- | Instantiate this class to register a way of deserializing a type based -- on the request's @Content-Type@ header. -- -- >>> import Network.HTTP.Media hiding (Accept) -- >>> import qualified Data.ByteString.Lazy.Char8 as BSC -- >>> data MyContentType = MyContentType String -- -- >>> :{ --instance Accept MyContentType where -- contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") -- :} -- -- >>> :{ --instance Read a => MimeUnrender MyContentType a where -- mimeUnrender _ bs = case BSC.take 12 bs of -- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs -- _ -> Left "didn't start with the magic incantation" -- :} -- -- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int -- class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a mimeUnrender p = mimeUnrenderWithType p (contentType p) -- | Variant which is given the actual 'M.MediaType' provided by the other party. -- -- In the most cases you don't want to branch based on the 'M.MediaType'. -- See for a motivating example. mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a mimeUnrenderWithType p _ = mimeUnrender p {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} class AllCTUnrender (list :: [*]) a where canHandleCTypeH :: Proxy list -> ByteString -- Content-Type header -> Maybe (ByteString -> Either String a) handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where canHandleCTypeH p ctypeH = M.mapContentMedia (allMimeUnrender p) (cs ctypeH) -------------------------------------------------------------------------- -- * Utils (Internal) class AllMime (list :: [*]) where allMime :: Proxy list -> [M.MediaType] instance AllMime '[] where allMime _ = [] instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeRender -------------------------------------------------------------------------- class (AllMime list) => AllMimeRender (list :: [*]) a where allMimeRender :: Proxy list -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp where bs = mimeRender pctyp a pctyp = Proxy :: Proxy ctyp instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where allMimeRender _ a = map (, bs) (NE.toList $ contentTypes pctyp) ++ allMimeRender pctyps a where bs = mimeRender pctyp a pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy (ctyp' ': ctyps) -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and -- then this would be taken care of. However there is no more specific instance -- between that and 'MimeRender JSON a', so we do this instead instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp where pctyp = Proxy :: Proxy ctyp instance {-# OVERLAPPING #-} ( AllMime (ctyp ': ctyp' ': ctyps) ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where allMimeRender p _ = zip (allMime p) (repeat "") -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender -------------------------------------------------------------------------- class (AllMime list) => AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list -> [(M.MediaType, ByteString -> Either String a)] instance AllMimeUnrender '[] a where allMimeUnrender _ = [] instance ( MimeUnrender ctyp a , AllMimeUnrender ctyps a ) => AllMimeUnrender (ctyp ': ctyps) a where allMimeUnrender _ = map mk (NE.toList $ contentTypes pctyp) ++ allMimeUnrender pctyps where mk ct = (ct, mimeUnrenderWithType pctyp ct) pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps -------------------------------------------------------------------------- -- * MimeRender Instances -- | `encode` instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @urlEncodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) instance {-# OVERLAPPABLE #-} ToForm a => MimeRender FormUrlEncoded a where mimeRender _ = urlEncodeAsForm -- | `TextL.encodeUtf8` instance MimeRender PlainText TextL.Text where mimeRender _ = TextL.encodeUtf8 -- | @fromStrict . TextS.encodeUtf8@ instance MimeRender PlainText TextS.Text where mimeRender _ = fromStrict . TextS.encodeUtf8 -- | @BC.pack@ instance MimeRender PlainText String where mimeRender _ = BC.pack -- | @id@ instance MimeRender OctetStream ByteString where mimeRender _ = id -- | `fromStrict` instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict -- | A type for responses without content-body. data NoContent = NoContent deriving (Show, Eq, Read, Generic) instance NFData NoContent -------------------------------------------------------------------------- -- * MimeUnrender Instances -- | 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 -- -- >>> 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") -- | `eitherDecode` instance FromJSON a => MimeUnrender JSON a where mimeUnrender _ = eitherDecodeLenient -- | @urlDecodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) instance FromForm a => MimeUnrender FormUrlEncoded a where mimeUnrender _ = left TextS.unpack . urlDecodeAsForm -- | @left show . TextL.decodeUtf8'@ instance MimeUnrender PlainText TextL.Text where mimeUnrender _ = left show . TextL.decodeUtf8' -- | @left show . TextS.decodeUtf8' . toStrict@ instance MimeUnrender PlainText TextS.Text where mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict -- | @Right . BC.unpack@ instance MimeUnrender PlainText String where mimeUnrender _ = Right . BC.unpack -- | @Right . id@ instance MimeUnrender OctetStream ByteString where mimeUnrender _ = Right . id -- | @Right . toStrict@ instance MimeUnrender OctetStream BS.ByteString where mimeUnrender _ = Right . toStrict -- $setup -- >>> :set -XFlexibleInstances -- >>> :set -XMultiParamTypeClasses -- >>> :set -XOverloadedStrings -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.19.1/src/Servant/API/Description.hs0000644000000000000000000000501207346545000017114 0ustar0000000000000000{-# 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.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 :: [*]) :: 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 } servant-0.19.1/src/Servant/API/Empty.hs0000644000000000000000000000100307346545000015723 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Empty(EmptyAPI(..)) where import Data.Typeable (Typeable) import Prelude () import Prelude.Compat -- | 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) servant-0.19.1/src/Servant/API/Experimental/0000755000000000000000000000000007346545000016734 5ustar0000000000000000servant-0.19.1/src/Servant/API/Experimental/Auth.hs0000644000000000000000000000072307346545000020173 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} module Servant.API.Experimental.Auth where import Data.Typeable (Typeable) -- | A generalized Authentication combinator. Use this if you have a -- non-standard authentication technique. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE. data AuthProtect (tag :: k) deriving (Typeable) servant-0.19.1/src/Servant/API/Fragment.hs0000644000000000000000000000125407346545000016400 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Fragment (Fragment) where 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 :: *) deriving Typeable -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Tracking -- >>> instance ToJSON Tracking where { toJSON = undefined } servant-0.19.1/src/Servant/API/Generic.hs0000644000000000000000000001164707346545000016220 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | 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.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 :: * 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 servant-0.19.1/src/Servant/API/Header.hs0000644000000000000000000000156607346545000016033 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Header ( Header, Header', ) where import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) import Servant.API.Modifiers -- | Extract the given header's value as a value of type @a@. -- I.e. header sent by client, parsed by server. -- -- Example: -- -- >>> newtype Referer = Referer Text deriving (Eq, Show) -- >>> -- >>> -- GET /view-my-referer -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer type Header = Header' '[Optional, Strict] data Header' (mods :: [*]) (sym :: Symbol) (a :: *) deriving Typeable -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text servant-0.19.1/src/Servant/API/HttpVersion.hs0000644000000000000000000000076307346545000017126 0ustar0000000000000000module Servant.API.HttpVersion ( -- $httpversion HttpVersion(..) ) where import Network.HTTP.Types (HttpVersion (..)) -- $httpversion -- -- | You can directly use the 'HttpVersion' type from @Network.HTTP.Types@ -- if your request handlers need it to compute a response. This would -- make the request handlers take an argument of type 'HttpVersion'. -- -- Example: -- -- >>> type API = HttpVersion :> Get '[JSON] String -- $setup -- >>> import Servant.API servant-0.19.1/src/Servant/API/IsSecure.hs0000644000000000000000000000267507346545000016367 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Servant.API.IsSecure ( -- $issecure IsSecure(..) ) where import Data.Typeable (Typeable) import GHC.Generics (Generic) -- | Was this request made over an SSL connection? -- -- Note that this value will not tell you if the client originally -- made this request over SSL, but rather whether the current -- connection is SSL. The distinction lies with reverse proxies. -- In many cases, the client will connect to a load balancer over SSL, -- but connect to the WAI handler without SSL. In such a case, -- the handlers would get 'NotSecure', but from a user perspective, -- there is a secure connection. data IsSecure = Secure -- ^ the connection to the server -- is secure (HTTPS) | NotSecure -- ^ the connection to the server -- is not secure (HTTP) deriving (Eq, Show, Read, Generic, Ord, Typeable) -- $issecure -- -- | Use 'IsSecure' whenever your request handlers need to know whether -- the connection to the server is secure or not. -- This would make the request handlers receive an argument of type 'IsSecure', -- whose value can be one of 'Secure' (HTTPS) or 'NotSecure' (HTTP). -- -- Example: -- -- >>> type API = "sensitive-data" :> IsSecure :> Get '[JSON] NationSecrets -- $setup -- >>> import Servant.API -- >>> data NationSecrets servant-0.19.1/src/Servant/API/Modifiers.hs0000644000000000000000000001200507346545000016552 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} 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.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 :: [*]) :: 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 :: [*]) :: 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 servant-0.19.1/src/Servant/API/NamedRoutes.hs0000644000000000000000000000042207346545000017057 0ustar0000000000000000{-# LANGUAGE KindSignatures #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.NamedRoutes ( -- * NamedRoutes combinator NamedRoutes ) where -- | Combinator for embedding a record of named routes into a Servant API type. data NamedRoutes (api :: * -> *) servant-0.19.1/src/Servant/API/QueryParam.hs0000644000000000000000000000376207346545000016731 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) import Servant.API.Modifiers -- | Lookup the value associated to the @sym@ query string parameter -- and try to extract it as a value of type @a@. -- -- Example: -- -- >>> -- /books?author= -- >>> type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] type QueryParam = QueryParam' '[Optional, Strict] -- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise. data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *) deriving Typeable -- | Lookup the values associated to the @sym@ query string parameter -- and try to extract it as a value of type @[a]@. This is typically -- meant to support query string parameters of the form -- @param[]=val1¶m[]=val2@ and so on. Note that servant doesn't actually -- require the @[]@s and will fetch the values just fine with -- @param=val1¶m=val2@, too. -- -- Example: -- -- >>> -- /books?authors[]=&authors[]=&... -- >>> type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] data QueryParams (sym :: Symbol) (a :: *) deriving Typeable -- | Lookup a potentially value-less query string parameter -- with boolean semantics. If the param @sym@ is there without any value, -- or if it's there with value "true" or "1", it's interpreted as 'True'. -- Otherwise, it's interpreted as 'False'. -- -- Example: -- -- >>> -- /books?published -- >>> type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] data QueryFlag (sym :: Symbol) -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.19.1/src/Servant/API/Raw.hs0000644000000000000000000000137507346545000015372 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Raw where import Data.Typeable (Typeable) -- | Endpoint for plugging in your own Wai 'Application's. -- -- The given 'Application' will get the request as received by the server, potentially with -- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's, -- this can also be used with functions from -- -- to serve static files stored in a particular directory on your filesystem data Raw deriving Typeable servant-0.19.1/src/Servant/API/RemoteHost.hs0000644000000000000000000000125107346545000016723 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Servant.API.RemoteHost ( -- $remotehost RemoteHost ) where import Data.Typeable (Typeable) -- | Provides access to the host or IP address -- from which the HTTP request was sent. data RemoteHost deriving Typeable -- $remotehost -- -- Use 'RemoteHost' whenever your request handlers need the host or IP address -- from which the client issued the HTTP request. The corresponding handlers -- receive arguments of type @SockAddr@ (from @Network.Socket@). -- -- Example: -- -- >>> -- POST /record-ip -- >>> type API = "record-ip" :> RemoteHost :> Post '[] () -- $setup -- >>> import Servant.API servant-0.19.1/src/Servant/API/ReqBody.hs0000644000000000000000000000147207346545000016204 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.ReqBody ( ReqBody, ReqBody', ) where import Data.Typeable (Typeable) import Servant.API.Modifiers -- | Extract the request body as a value of type @a@. -- -- Example: -- -- >>> -- POST /books -- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book type ReqBody = ReqBody' '[Required, Strict] -- | -- -- /Note:/ 'ReqBody'' is always 'Required'. data ReqBody' (mods :: [*]) (contentTypes :: [*]) (a :: *) deriving (Typeable) -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.19.1/src/Servant/API/ResponseHeaders.hs0000644000000000000000000002230507346545000017727 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int -- -- The value is added to the header specified by the type (@Location@ in the -- example above). module Servant.API.ResponseHeaders ( Headers(..) , ResponseHeader (..) , AddHeader , addHeader , noHeader , HasResponseHeader , lookupResponseHeader , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders) , GetHeaders' , HeaderValMap , HList(..) ) where import Control.DeepSeq (NFData (..)) import Data.ByteString.Char8 as BS (ByteString, init, pack, unlines) import qualified Data.CaseInsensitive as CI import Data.Proxy import Data.Typeable (Typeable) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import qualified Network.HTTP.Types.Header as HTTP import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) import Prelude () import Prelude.Compat import Servant.API.Header (Header) -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addOptionalHeader'. data Headers ls a = Headers { getResponse :: a -- ^ The underlying value of a 'Headers' , getHeadersHList :: HList ls -- ^ HList of headers. } deriving (Functor) instance (NFDataHList ls, NFData a) => NFData (Headers ls a) where rnf (Headers x hdrs) = rnf x `seq` rnf hdrs data ResponseHeader (sym :: Symbol) a = Header a | MissingHeader | UndecodableHeader ByteString deriving (Typeable, Eq, Show, Functor) instance NFData a => NFData (ResponseHeader sym a) where rnf MissingHeader = () rnf (UndecodableHeader bs) = rnf bs rnf (Header x) = rnf x data HList a where HNil :: HList '[] HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs) class NFDataHList xs where rnfHList :: HList xs -> () instance NFDataHList '[] where rnfHList HNil = () instance (y ~ Header 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 :: * -> *) (xs :: [*]) where HeaderValMap f '[] = '[] HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs class BuildHeadersTo hs where buildHeadersTo :: [HTTP.Header] -> HList hs -- ^ Note: if there are multiple occurrences of a header in the argument, -- the values are interspersed with commas before deserialization (see -- ) instance {-# OVERLAPPING #-} BuildHeadersTo '[] where buildHeadersTo _ = HNil instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) => BuildHeadersTo (Header h v ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers in case matching of [] -> MissingHeader `HCons` buildHeadersTo headers xs -> case parseHeader (BS.init $ BS.unlines xs) of Left _err -> UndecodableHeader (BS.init $ BS.unlines xs) `HCons` buildHeadersTo headers Right h -> Header h `HCons` buildHeadersTo headers -- * Getting headers class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance class GetHeadersFromHList hs where getHeadersFromHList :: HList hs -> [HTTP.Header] instance GetHeadersFromHList hs => GetHeaders (HList hs) where getHeaders = getHeadersFromHList instance GetHeadersFromHList '[] where getHeadersFromHList _ = [] instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs) => GetHeadersFromHList (Header h x ': xs) where getHeadersFromHList hdrs = case hdrs of Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest UndecodableHeader h `HCons` rest -> (headerName, h) : getHeadersFromHList rest MissingHeader `HCons` rest -> getHeadersFromHList rest where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance class GetHeaders' hs where getHeaders' :: Headers hs a -> [HTTP.Header] instance GetHeaders' hs => GetHeaders (Headers hs a) where getHeaders = getHeaders' -- | This instance is an optimisation instance GetHeaders' '[] where getHeaders' _ = [] instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v) => GetHeaders' (Header 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 addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -- In this instance, we add a Header on top of something that is already decorated with some headers instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads) -- In this instance, 'a' parameter is decorated with a Header. instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a) => AddHeader h v a new where addOptionalHeader hdr resp = Headers resp (HCons hdr HNil) -- | @addHeader@ adds a header to a response. Note that it changes the type of -- the value in the following ways: -- -- 1. A simple value is wrapped in "Headers '[hdr]": -- -- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; -- >>> getHeaders example1 -- [("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 h v orig new => v -> orig -> new addHeader = addOptionalHeader . Header -- | Deliberately do not add a header to a value. -- -- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String -- >>> getHeaders example1 -- [] noHeader :: AddHeader h v orig new => orig -> new noHeader = addOptionalHeader MissingHeader class HasResponseHeader h a headers where hlistLookupHeader :: HList headers -> ResponseHeader h a instance {-# OVERLAPPING #-} HasResponseHeader h a (Header h a ': rest) where hlistLookupHeader (HCons ha _) = ha instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where hlistLookupHeader (HCons _ hs) = hlistLookupHeader hs -- | Look up a specific ResponseHeader, -- without having to know what position it is in the HList. -- -- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String -- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String -- >>> lookupResponseHeader example2 :: ResponseHeader "someheader" Int -- Header 5 -- -- >>> lookupResponseHeader example2 :: ResponseHeader "1st" Bool -- Header True -- -- Usage of this function relies on an explicit type annotation of the header to be looked up. -- This can be done with type annotations on the result, or with an explicit type application. -- In this example, the type of header value is determined by the type-inference, -- we only specify the name of the header: -- -- >>> :set -XTypeApplications -- >>> case lookupResponseHeader @"1st" example2 of { Header b -> b ; _ -> False } -- True -- -- @since 0.15 -- lookupResponseHeader :: (HasResponseHeader h a headers) => Headers headers r -> ResponseHeader h a lookupResponseHeader = hlistLookupHeader . getHeadersHList -- $setup -- >>> :set -XFlexibleContexts -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.19.1/src/Servant/API/Status.hs0000644000000000000000000000645007346545000016123 0ustar0000000000000000{-# 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 servant-0.19.1/src/Servant/API/Stream.hs0000644000000000000000000002046207346545000016072 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# 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.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 :: *) (contentType :: *) (a :: *) deriving (Typeable, Generic) type StreamGet = Stream 'GET 200 type StreamPost = Stream 'POST 200 -- | A stream request body. type StreamBody = StreamBody' '[] data StreamBody' (mods :: [*]) (framing :: *) (contentType :: *) (a :: *) 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 -> a instance MonadIO m => FromSourceIO a (SourceT m a) where fromSourceIO = 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)) servant-0.19.1/src/Servant/API/Sub.hs0000644000000000000000000000133407346545000015365 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Sub ((:>)) where import Data.Typeable (Typeable) -- | The contained API (second argument) can be found under @("/" ++ path)@ -- (path being the first argument). -- -- Example: -- -- >>> -- GET /hello/world -- >>> -- returning a JSON encoded World value -- >>> type MyApi = "hello" :> "world" :> Get '[JSON] World data (path :: k) :> (a :: *) deriving (Typeable) infixr 4 :> -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data World -- >>> instance ToJSON World where { toJSON = undefined } servant-0.19.1/src/Servant/API/TypeErrors.hs0000644000000000000000000000254507346545000016757 0ustar0000000000000000{-# 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, ) where import Data.Kind 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 servant-0.19.1/src/Servant/API/TypeLevel.hs0000644000000000000000000002441207346545000016547 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# 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, AtLeastOneFragment ) where import GHC.Exts (Constraint) import Servant.API.Alternative (type (:<|>)) import Servant.API.Capture (Capture, CaptureAll) import Servant.API.Fragment import Servant.API.Header (Header) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.ReqBody (ReqBody) import Servant.API.Sub (type (:>)) import Servant.API.Verbs (Verb) 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 (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 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 :: *) (api :: *) :: Constraint where IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb) IsIn (e :> sa) (e :> sb) = IsIn sa sb IsIn e e = () -- | 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 class FragmentUnique api => AtLeastOneFragment api -- | If fragment appeared in API endpoint twice, compile-time error would be raised. -- -- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent -- >>> instance AtLeastOneFragment FailAPI -- ... -- ...Only one Fragment allowed per endpoint in api... -- ... -- ...In the instance declaration for... instance AtLeastOneFragment (Verb m s ct typ) instance AtLeastOneFragment (UVerb m cts as) instance AtLeastOneFragment (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 servant-0.19.1/src/Servant/API/UVerb.hs0000644000000000000000000001262007346545000015657 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | 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.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.UVerb.Union class KnownStatus (StatusOf a) => HasStatus (a :: *) where type StatusOf (a :: *) :: 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 :: [*]) where type Statuses (as :: [*]) :: [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 -- | 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 :: [*]) (as :: [*]) 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 servant-0.19.1/src/Servant/API/UVerb/0000755000000000000000000000000007346545000015322 5ustar0000000000000000servant-0.19.1/src/Servant/API/UVerb/Union.hs0000644000000000000000000001160707346545000016753 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# 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.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 :: * -> Constraint) (a :: *) (as :: [*]). 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 :: *) (as :: [*]). (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 list. This will throw nice errors if the element is not in the -- list, or if there is a duplicate 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 _ '[] = 'False Elem x (x' ': xs) = If (x == x') 'True (Elem x xs) 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 servant-0.19.1/src/Servant/API/Vault.hs0000644000000000000000000000103107346545000015721 0ustar0000000000000000module Servant.API.Vault ( -- $vault Vault ) where import Data.Vault.Lazy (Vault) -- $vault -- -- | Use 'Vault' in your API types to provide access to the 'Vault' -- of the request, which is a location shared by middlewares and applications -- to store arbitrary data. See -- for more details on how to actually use the vault in your handlers -- -- Example: -- -- >>> type API = Vault :> Get '[JSON] String -- $setup -- >>> import Servant.API servant-0.19.1/src/Servant/API/Verbs.hs0000644000000000000000000001423307346545000015717 0ustar0000000000000000{-# 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.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 :: *) deriving (Typeable, Generic) -- | @NoContentVerb@ is a specific type to represent 'NoContent' responses. -- It does not require either a list of content types (because there's -- no content) or a status code (because it should always be 204). data NoContentVerb (method :: k1) deriving (Typeable, Generic) -- * 200 responses -- -- The 200 response is the workhorse of web servers, but also fairly generic. -- When appropriate, you should prefer the more specific success combinators. -- More information about the definitions of status codes can be found in -- and -- ; -- the relevant information is summarily presented here. -- | 'GET' with 200 status code. type Get = Verb 'GET 200 -- | 'POST' with 200 status code. type Post = Verb 'POST 200 -- | 'PUT' with 200 status code. type Put = Verb 'PUT 200 -- | 'DELETE' with 200 status code. type Delete = Verb 'DELETE 200 -- | 'PATCH' with 200 status code. type Patch = Verb 'PATCH 200 -- * Other responses -- ** 201 Created -- -- Indicates that a new resource has been created. The URI corresponding to the -- resource should be given in the @Location@ header field. -- -- If the operation is idempotent, use 'PutCreated'. If not, use 'PostCreated' -- -- If the resource cannot be created immediately, use 'PostAccepted'. -- -- Consider using 'Servant.Links.safeLink' for the @Location@ header -- field. -- | 'POST' with 201 status code. type PostCreated = Verb 'POST 201 -- | 'PUT' with 201 status code. type PutCreated = Verb 'PUT 201 -- ** 202 Accepted -- -- Indicates that the request has been accepted for processing, but the -- processing has not yet completed. The status of the processing should be -- included, as well as either a link to a status monitoring endpoint or an -- estimate of when the processing will be finished. -- | 'GET' with 202 status code. type GetAccepted = Verb 'GET 202 -- | 'POST' with 202 status code. type PostAccepted = Verb 'POST 202 -- | 'DELETE' with 202 status code. type DeleteAccepted = Verb 'DELETE 202 -- | 'PATCH' with 202 status code. type PatchAccepted = Verb 'PATCH 202 -- | 'PUT' with 202 status code. type PutAccepted = Verb 'PUT 202 -- ** 203 Non-Authoritative Information -- -- Indicates that the request has been successfully processed, but the -- information may come from a third-party. -- | 'GET' with 203 status code. type GetNonAuthoritative = Verb 'GET 203 -- | 'POST' with 203 status code. type PostNonAuthoritative = Verb 'POST 203 -- | 'DELETE' with 203 status code. type DeleteNonAuthoritative = Verb 'DELETE 203 -- | 'PATCH' with 203 status code. type PatchNonAuthoritative = Verb 'PATCH 203 -- | 'PUT' with 203 status code. type PutNonAuthoritative = Verb 'PUT 203 -- ** 204 No Content -- -- Indicates that no response body is being returned. Handlers for these should -- return 'NoContent', possibly with headers. -- -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code. type GetNoContent = NoContentVerb 'GET -- | 'POST' with 204 status code. type PostNoContent = NoContentVerb 'POST -- | 'DELETE' with 204 status code. type DeleteNoContent = NoContentVerb 'DELETE -- | 'PATCH' with 204 status code. type PatchNoContent = NoContentVerb 'PATCH -- | 'PUT' with 204 status code. type PutNoContent = NoContentVerb 'PUT -- | 'HEAD' with 204 status code. type HeadNoContent = NoContentVerb 'HEAD -- ** 205 Reset Content -- -- Indicates that no response body is being returned. Handlers for these should -- return 'NoContent', possibly with Headers. -- -- If the document view should not be reset, use @204 No Content@. -- | 'GET' with 205 status code. type GetResetContent = Verb 'GET 205 -- | 'POST' with 205 status code. type PostResetContent = Verb 'POST 205 -- | 'DELETE' with 205 status code. type DeleteResetContent = Verb 'DELETE 205 -- | 'PATCH' with 205 status code. type PatchResetContent = Verb 'PATCH 205 -- | 'PUT' with 205 status code. type PutResetContent = Verb 'PUT 205 -- ** 206 Partial Content -- -- Indicates that the server is delivering part of the resource due to a range -- header in the request. -- -- For more information, see -- | 'GET' with 206 status code. type GetPartialContent = Verb 'GET 206 class ReflectMethod a where reflectMethod :: Proxy a -> Method instance ReflectMethod 'GET where reflectMethod _ = methodGet instance ReflectMethod 'POST where reflectMethod _ = methodPost instance ReflectMethod 'PUT where reflectMethod _ = methodPut instance ReflectMethod 'DELETE where reflectMethod _ = methodDelete instance ReflectMethod 'PATCH where reflectMethod _ = methodPatch instance ReflectMethod 'HEAD where reflectMethod _ = methodHead instance ReflectMethod 'OPTIONS where reflectMethod _ = methodOptions instance ReflectMethod 'TRACE where reflectMethod _ = methodTrace instance ReflectMethod 'CONNECT where reflectMethod _ = methodConnect servant-0.19.1/src/Servant/API/WithNamedContext.hs0000644000000000000000000000133207346545000020057 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} module Servant.API.WithNamedContext where import GHC.TypeLits -- | 'WithNamedContext' names a specific tagged context to use for the -- combinators in the API. (See also in @servant-server@, -- @Servant.Server.Context@.) For example: -- -- > type UseNamedContextAPI = WithNamedContext "myContext" '[String] ( -- > ReqBody '[JSON] Int :> Get '[JSON] Int) -- -- Both the 'ReqBody' and 'Get' combinators will use the 'WithNamedContext' with -- type tag "myContext" as their context. -- -- 'Context's are only relevant for @servant-server@. -- -- For more information, see the tutorial. data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi servant-0.19.1/src/Servant/Links.hs0000644000000000000000000005364007346545000015312 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# 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.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 ) where import Data.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 Prelude () import Prelude.Compat import Servant.API.Alternative ((:<|>) ((:<|>))) import Servant.API.BasicAuth (BasicAuth) import Servant.API.Capture (Capture', CaptureAll) import Servant.API.Description (Description, Summary) import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.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.Raw (Raw) 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 Web.HttpApiData import Data.Kind (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 :: [Escaped] , _queryParams :: [Param] , _fragment :: Fragment' } deriving Show newtype Escaped = Escaped String type Fragment' = Maybe String escaped :: String -> Escaped escaped = Escaped . escapeURIString isUnreserved getEscaped :: Escaped -> String getEscaped (Escaped s) = s instance Show Escaped where showsPrec d (Escaped s) = showsPrec d s show (Escaped s) = show s linkSegments :: Link -> [String] linkSegments = map getEscaped . _segments linkQueryParams :: Link -> [Param] linkQueryParams = _queryParams 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] } addQueryParam :: Param -> Link -> Link addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } 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) (intercalate "/" $ map getEscaped segments) (makeQueries q_params) (makeFragment mfragment) where makeQueries :: [Param] -> String makeQueries [] = "" makeQueries xs = "?" <> intercalate "&" (fmap makeQuery xs) makeQuery :: Param -> String makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v) makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k 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 :: * -- = 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 :: *) 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 :: *) toLink :: (Link -> a) -> Proxy endpoint -- ^ The API endpoint you would like to point to -> Link -> MkLink endpoint a -- Naked symbol instance instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where type MkLink (sym :> sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg) where seg = symbolVal (Proxy :: Proxy sym) -- QueryParam instances instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods)) => HasLink (QueryParam' mods sym v :> sub) where type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a toLink toA _ l mv = toLink toA (Proxy :: Proxy sub) $ case sbool :: SBool (FoldRequired mods) of STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l where k :: String k = symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) => HasLink (QueryParams sym v :> sub) where type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a toLink toA _ l = toLink toA (Proxy :: Proxy sub) . foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l where k = symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, HasLink sub) => HasLink (QueryFlag sym :> sub) where type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a toLink toA _ l False = toLink toA (Proxy :: Proxy sub) l toLink toA _ l True = toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l where k = symbolVal (Proxy :: Proxy sym) -- :<|> instance - Generate all links at once instance (HasLink a, HasLink b) => HasLink (a :<|> b) where type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l -- Misc instances instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r toLink toA _ = toLink toA (Proxy :: Proxy sub) instance 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) $ foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where type MkLink (Header' mods sym a :> sub) r = MkLink sub r toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (Vault :> sub) where type MkLink (Vault :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (Description s :> sub) where type MkLink (Description s :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (Summary s :> sub) where type MkLink (Summary s :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (HttpVersion :> sub) where type MkLink (HttpVersion:> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (IsSecure :> sub) where type MkLink (IsSecure :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (WithNamedContext name context sub) where type MkLink (WithNamedContext name context sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy :: Proxy sub) instance HasLink sub => HasLink (RemoteHost :> sub) where type MkLink (RemoteHost :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (BasicAuth realm a :> sub) where type MkLink (BasicAuth realm a :> sub) r = MkLink sub r toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink EmptyAPI where type MkLink EmptyAPI a = EmptyAPI toLink _ _ _ = EmptyAPI -- Verb (terminal) instances instance HasLink (Verb m s ct a) where type MkLink (Verb m s ct a) r = r toLink toA _ = toA instance HasLink (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 (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 :: * -> *) (a :: *) 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 ) => 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 :: * -> 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 servant-0.19.1/src/Servant/Test/0000755000000000000000000000000007346545000014605 5ustar0000000000000000servant-0.19.1/src/Servant/Test/ComprehensiveAPI.hs0000644000000000000000000000632007346545000020303 0ustar0000000000000000{-# 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 :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint comprehensiveAPIWithoutStreamingOrRaw :: Proxy ComprehensiveAPIWithoutStreamingOrRaw comprehensiveAPIWithoutStreamingOrRaw = Proxy servant-0.19.1/src/Servant/Types/0000755000000000000000000000000007346545000014772 5ustar0000000000000000servant-0.19.1/src/Servant/Types/SourceT.hs0000644000000000000000000002771107346545000016722 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} 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 () import Prelude.Compat hiding (readFile) import System.IO (Handle, IOMode (..), withFile) import qualified Test.QuickCheck as QC -- $setup -- >>> :set -XOverloadedStrings -- >>> 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..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 return -- | >>> 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 -- | >>> 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) 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 . return <$> 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 :: [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 = return [] 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 = return Nothing uncons (Skip s) = uncons s uncons (Yield x s) = return (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") -- '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 = return () go (Skip s) = go s go (Yield x s) = g x >> go s go (Error err) = f err go (Effect ms) = ms >>= go ------------------------------------------------------------------------------- -- 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: 2.2 -- 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 ["1 2 3"]) -- Right ["1","2","3"] -- -- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2", "3"]) -- Right ["123"] -- -- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2 3", "4"]) -- Right ["12","34"] -- -- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["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) servant-0.19.1/test/Servant/API/0000755000000000000000000000000007346545000014467 5ustar0000000000000000servant-0.19.1/test/Servant/API/ContentTypesSpec.hs0000644000000000000000000003063507346545000020304 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where import Prelude () import Prelude.Compat import Data.Aeson (FromJSON, ToJSON (..), Value, decode, encode, object, (.=)) import Data.ByteString.Char8 (ByteString, append, pack) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Either import Data.Function (on) import Data.List (sortBy) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust, isJust, isNothing) import Data.Proxy import Data.String (IsString (..)) import Data.String.Conversions (cs) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextSE import qualified Data.Text.Lazy as TextL import Control.Exception (evaluate) import GHC.Generics import Test.Hspec import Test.QuickCheck import "quickcheck-instances" Test.QuickCheck.Instances () import Text.Read (readMaybe) import Servant.API.ContentTypes spec :: Spec spec = describe "Servant.API.ContentTypes" $ do describe "handleAcceptH" $ do let p = Proxy :: Proxy '[PlainText] it "matches any charset if none were provided" $ do let without = handleAcceptH p (AcceptHeader "text/plain") with = handleAcceptH p (AcceptHeader "text/plain;charset=utf-8") wisdom = "ubi sub ubi" :: String without wisdom `shouldBe` with wisdom it "does not match non utf-8 charsets" $ do let badCharset = handleAcceptH p (AcceptHeader "text/plain;charset=whoknows") s = "cheese" :: String badCharset s `shouldBe` Nothing describe "The JSON Content-Type type" $ do let p = Proxy :: Proxy JSON it "handles whitespace at end of input" $ do mimeUnrender p "[1] " `shouldBe` Right [1 :: Int] it "handles whitespace at beginning of input" $ do mimeUnrender p " [1] " `shouldBe` Right [1 :: Int] it "does not like junk at end of input" $ do mimeUnrender p "[1] this probably shouldn't work" `shouldSatisfy` (isLeft :: Either a [Int] -> Bool) it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::[Int]) it "has mimeUnrender reverse mimeRender for valid top-level json " $ do property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData) describe "The NoContent Content-Type type" $ do let p = Proxy :: Proxy '[JSON] it "does not render any content" $ allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd)) it "evaluates the NoContent value" $ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall describe "The PlainText Content-Type type" $ do let p = Proxy :: Proxy PlainText it "has mimeUnrender reverse mimeRender (lazy Text)" $ do property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextL.Text) it "has mimeUnrender reverse mimeRender (strict Text)" $ do property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextS.Text) describe "The OctetStream Content-Type type" $ do let p = Proxy :: Proxy OctetStream it "is id (Lazy ByteString)" $ do property $ \x -> mimeRender p x == (x :: BSL.ByteString) && mimeUnrender p x == Right x it "is fromStrict/toStrict (Strict ByteString)" $ do property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString) && mimeUnrender p (BSL.fromStrict x) == Right x describe "handleAcceptH" $ do it "returns Nothing if the 'Accept' header doesn't match" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "text/plain" (3 :: Int) `shouldSatisfy` isNothing it "returns Just if the 'Accept' header matches" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) `shouldSatisfy` isJust handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int) `shouldSatisfy` isJust handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) "application/octet-stream" ("content" :: ByteString) `shouldSatisfy` isJust it "returns Just if the 'Accept' header matches, with multiple mime types" $ do handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int) `shouldSatisfy` isJust handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int) `shouldSatisfy` isJust handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int) `shouldBe` Nothing it "returns the Content-Type as the first element of the tuple" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int) `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) "application/octet-stream" ("content" :: ByteString) `shouldSatisfy` ((== "application/octet-stream") . fst . fromJust) it "returns the appropriately serialized representation" $ do property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData) == Just ("application/json;charset=utf-8", encode x) it "respects the Accept spec ordering" $ do let highest a b c = last $ sortBy (compare `on` snd) -- when qualities are same, http-media-0.8 picks first; 0.7 last. #if MIN_VERSION_http_media(0,8,0) [ ("text/plain;charset=utf-8", c) , ("application/json;charset=utf-8", b) , ("application/octet-stream", a) ] #else [ ("application/octet-stream", a) , ("application/json;charset=utf-8", b) , ("text/plain;charset=utf-8", c) ] #endif let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $ addToAccept (Proxy :: Proxy JSON) b $ addToAccept (Proxy :: Proxy PlainText ) c $ "" let val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText]) (acceptH a b c) (i :: Int) property $ \a b c i -> let acc = acceptH a b c in counterexample (show acc) $ fst (fromJust $ val a b c i) === fst (highest a b c) describe "handleCTypeH" $ do it "returns Nothing if the 'Content-Type' header doesn't match" $ do handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 " `shouldBe` (Nothing :: Maybe (Either String Value)) context "the 'Content-Type' header matches" $ do it "returns Just if the parameter matches" $ do handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) it "returns Just if there is no parameter" $ do handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) it "returns Just Left if the decoding fails" $ do let isJustLeft :: Maybe (Either String Value) -> Bool isJustLeft (Just (Left _)) = True isJustLeft _ = False handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- " `shouldSatisfy` isJustLeft it "returns Just (Right val) if the decoding succeeds" $ do let val = SomeData "Of cabbages--and kings" 12 handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" (encode val) `shouldBe` Just (Right val) it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do let val = 42 :: Int handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json" "42" `shouldBe` Just (Right val) handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain" "42" `shouldBe` Just (Right val) handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" "42" `shouldBe` (Nothing :: Maybe (Either String Int)) it "passes content-type to mimeUnrenderWithType" $ do let val = "foobar" :: TextS.Text handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json" "\"foobar\"" `shouldBe` Just (Right val) handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain" "foobar" `shouldBe` Just (Right val) handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" "foobar" `shouldBe` (Nothing :: Maybe (Either String Int)) -- aeson >= 0.9 decodes top-level strings describe "eitherDecodeLenient" $ do 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) data SomeData = SomeData { record1 :: String, record2 :: Int } deriving (Generic, Eq, Show) newtype ZeroToOne = ZeroToOne Float deriving (Eq, Show, Ord) instance FromJSON SomeData instance ToJSON SomeData instance Arbitrary SomeData where arbitrary = SomeData <$> arbitrary <*> arbitrary instance Arbitrary ZeroToOne where arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] instance MimeRender OctetStream Int where mimeRender _ = cs . show instance MimeRender PlainText Int where mimeRender _ = cs . show instance MimeRender PlainText ByteString where mimeRender _ = cs instance ToJSON ByteString where toJSON x = object [ "val" .= x ] instance IsString AcceptHeader where fromString = AcceptHeader . fromString -- To test multiple content types data JSONorText instance Accept JSONorText where contentTypes _ = "text/plain" NE.:| [ "application/json" ] instance MimeRender JSONorText Int where mimeRender _ = cs . 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) cont "" = new cont old = old `append` ", " `append` new servant-0.19.1/test/Servant/API/ResponseHeadersSpec.hs0000644000000000000000000000176507346545000020741 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Servant.API.ResponseHeadersSpec where import Test.Hspec import Servant.API.Header import Servant.API.ResponseHeaders spec :: Spec spec = describe "Servant.API.ResponseHeaders" $ do describe "addHeader" $ do it "adds a header to a value" $ do let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int getHeaders val `shouldBe` [("test", "hi")] it "maintains the value" $ do let val = addHeader "hi" 5 :: Headers '[Header "test" String] Int getResponse val `shouldBe` 5 it "adds headers to the front of the list" $ do let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int getHeaders val `shouldBe` [("first", "10"), ("second", "b")] describe "noHeader" $ do it "does not add a header" $ do let val = noHeader 5 :: Headers '[Header "test" Int] Int getHeaders val `shouldBe` [] servant-0.19.1/test/Servant/API/StreamSpec.hs0000644000000000000000000001047107346545000017074 0ustar0000000000000000{-# 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) servant-0.19.1/test/Servant/0000755000000000000000000000000007346545000014056 5ustar0000000000000000servant-0.19.1/test/Servant/LinksSpec.hs0000644000000000000000000001335507346545000016314 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Servant.LinksSpec where import Data.Proxy (Proxy (..)) import Data.String (fromString) import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Servant.API 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] -- All of the verbs :<|> "get" :> Get '[JSON] NoContent :<|> "put" :> Put '[JSON] NoContent :<|> "post" :> ReqBody '[JSON] Bool :> Post '[JSON] NoContent :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent :<|> "raw" :> Raw :<|> NoEndpoint type LinkableApi = "all" :> CaptureAll "names" String :> Get '[JSON] NoContent :<|> "get" :> Get '[JSON] NoContent apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint Link apiLink = safeLink (Proxy :: Proxy TestApi) -- | Convert a link to a URI and ensure that this maps to the given string -- given string shouldBeLink :: Link -> String -> Expectation shouldBeLink link expected = toUrlPiece link `shouldBe` fromString expected spec :: Spec spec = describe "Servant.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` "" -- 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 servant-0.19.1/test/0000755000000000000000000000000007346545000012434 5ustar0000000000000000servant-0.19.1/test/Spec.hs0000644000000000000000000000005407346545000013661 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}