servant-0.16.2/0000755000000000000000000000000007346545000011453 5ustar0000000000000000servant-0.16.2/CHANGELOG.md0000755000000000000000000006635307346545000013304 0ustar0000000000000000[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) 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 in, 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 a 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.16.2/LICENSE0000644000000000000000000000307307346545000012463 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.16.2/Setup.hs0000644000000000000000000000150107346545000013104 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal -- If the macro is defined, we have new cabal-install, -- but for some reason we don't have cabal-doctest in package-db -- -- Probably we are running cabal sdist, when otherwise using new-build -- workflow #warning You are configuring this package without cabal-doctest installed. \ The doctests test-suite will not work as a result. \ To fix this, install cabal-doctest before configuring. #endif import Distribution.Simple main :: IO () main = defaultMain #endif servant-0.16.2/servant.cabal0000644000000000000000000001332407346545000014124 0ustar0000000000000000cabal-version: >=1.10 name: servant version: 0.16.2 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: BSD3 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: Custom tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 extra-source-files: CHANGELOG.md source-repository head type: git location: http://github.com/haskell-servant/servant.git custom-setup setup-depends: base >= 4 && <5, Cabal, cabal-doctest >= 1.0.6 && <1.1 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.Generic Servant.API.Header Servant.API.HttpVersion Servant.API.IsSecure Servant.API.Modifiers Servant.API.QueryParam Servant.API.Raw Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Stream Servant.API.Sub Servant.API.TypeLevel 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 -- Deprecated modules, to be removed in late 2019 exposed-modules: Servant.Utils.Links Servant.API.Internal.Test.ComprehensiveAPI -- 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.13 , bytestring >= 0.10.8.1 && < 0.11 , mtl >= 2.2.2 && < 2.3 , transformers >= 0.5.2.0 && < 0.6 , text >= 1.2.3.0 && < 1.3 -- 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.4.2 , singleton-bool >= 0.1.5 && < 0.1.6 -- 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.11 , aeson >= 1.4.1.0 && < 1.5 , attoparsec >= 0.13.2.2 && < 0.14 , 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.2 , network-uri >= 2.6.1.0 && < 2.7 , QuickCheck >= 2.12.6.1 && < 2.14 , 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: CPP , ConstraintKinds , DataKinds , DeriveDataTypeable , FlexibleInstances , FunctionalDependencies , GADTs , KindSignatures , MultiParamTypeClasses , OverlappingInstances , OverloadedStrings , PolyKinds , QuasiQuotes , RecordWildCards , ScopedTypeVariables , TemplateHaskell , TypeFamilies , TypeOperators , TypeSynonymInstances , 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 -- Additonal dependencies build-depends: hspec >= 2.6.0 && < 2.8 , QuickCheck >= 2.12.6.1 && < 2.14 , quickcheck-instances >= 0.3.19 && < 0.4 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && < 2.8 test-suite doctests build-depends: base , servant , doctest >= 0.16.0 && <0.17 -- We test Links failure with doctest, so we need extra dependencies build-depends: hspec >= 2.6.0 && < 2.8 type: exitcode-stdio-1.0 main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never x-doctest-source-dirs: test x-doctest-modules: Servant.LinksSpec servant-0.16.2/src/Servant/0000755000000000000000000000000007346545000013664 5ustar0000000000000000servant-0.16.2/src/Servant/API.hs0000644000000000000000000001241407346545000014633 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.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, -- * 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.Header (Header, Header') 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.Vault (Vault) import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, GetNonAuthoritative, GetPartialContent, GetResetContent, Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative, Post, PostAccepted, PostCreated, PostNoContent, PostNonAuthoritative, PostResetContent, Put, PutAccepted, 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.16.2/src/Servant/API/0000755000000000000000000000000007346545000014275 5ustar0000000000000000servant-0.16.2/src/Servant/API/Alternative.hs0000644000000000000000000000370007346545000017107 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.Semigroup (Semigroup (..)) 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.16.2/src/Servant/API/BasicAuth.hs0000644000000000000000000000237507346545000016503 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.16.2/src/Servant/API/Capture.hs0000644000000000000000000000232207346545000016233 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.16.2/src/Servant/API/ContentTypes.hs0000644000000000000000000003554707346545000017306 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# 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 :> Get '[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 _ _ = 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.16.2/src/Servant/API/Description.hs0000644000000000000000000000502307346545000017114 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 support is not perfect \ -- \but it's still very readable." -- :> Get '[JSON] Book -- :} data Description (sym :: Symbol) deriving (Typeable) -- | Fold modifier list to decide whether argument should be parsed strictly or leniently. -- -- >>> :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.16.2/src/Servant/API/Empty.hs0000644000000000000000000000100307346545000015721 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.16.2/src/Servant/API/Experimental/0000755000000000000000000000000007346545000016732 5ustar0000000000000000servant-0.16.2/src/Servant/API/Experimental/Auth.hs0000644000000000000000000000072307346545000020171 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.16.2/src/Servant/API/Generic.hs0000644000000000000000000001164707346545000016216 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.16.2/src/Servant/API/Header.hs0000644000000000000000000000155707346545000016031 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.16.2/src/Servant/API/HttpVersion.hs0000644000000000000000000000076307346545000017124 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.16.2/src/Servant/API/Internal/Test/0000755000000000000000000000000007346545000016770 5ustar0000000000000000servant-0.16.2/src/Servant/API/Internal/Test/ComprehensiveAPI.hs0000644000000000000000000000030707346545000022465 0ustar0000000000000000module Servant.API.Internal.Test.ComprehensiveAPI {-# DEPRECATED "Use Servant.TestComprehensiveAPI" #-} ( module Servant.Test.ComprehensiveAPI ) where import Servant.Test.ComprehensiveAPI servant-0.16.2/src/Servant/API/IsSecure.hs0000644000000000000000000000267507346545000016365 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.16.2/src/Servant/API/Modifiers.hs0000644000000000000000000001200707346545000016552 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.16.2/src/Servant/API/QueryParam.hs0000644000000000000000000000376207346545000016727 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.16.2/src/Servant/API/Raw.hs0000644000000000000000000000135707346545000015370 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 to serve -- static files stored in a particular directory on your filesystem data Raw deriving Typeable servant-0.16.2/src/Servant/API/RemoteHost.hs0000644000000000000000000000125107346545000016721 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.16.2/src/Servant/API/ReqBody.hs0000644000000000000000000000147207346545000016202 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.16.2/src/Servant/API/ResponseHeaders.hs0000644000000000000000000002217307346545000017730 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | 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 occurences 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 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 -- 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 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) 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.16.2/src/Servant/API/Stream.hs0000644000000000000000000002054707346545000016074 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.Monoid ((<>)) 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.16.2/src/Servant/API/Sub.hs0000644000000000000000000000133407346545000015363 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.16.2/src/Servant/API/TypeLevel.hs0000644000000000000000000002053007346545000016542 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-| 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, ) where import GHC.Exts (Constraint) import Servant.API.Alternative (type (:<|>)) import Servant.API.Capture (Capture, CaptureAll) import Servant.API.Header (Header) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.ReqBody (ReqBody) import Servant.API.Sub (type (:>)) import Servant.API.Verbs (Verb) 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 deduce... -- ... -- -- 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 (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 deduce... -- ... -- -- 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 deduce... -- ... 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). -} -- $setup -- -- The doctests in this module are run with following preamble: -- -- >>> :set -XPolyKinds -- >>> :set -XGADTs -- >>> 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 -- >>> let sampleAPI = Proxy :: Proxy SampleAPI servant-0.16.2/src/Servant/API/Vault.hs0000644000000000000000000000103107346545000015717 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.16.2/src/Servant/API/Verbs.hs0000644000000000000000000001343507346545000015720 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) -- * 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 = Verb 'GET 204 -- | 'POST' with 204 status code. type PostNoContent = Verb 'POST 204 -- | 'DELETE' with 204 status code. type DeleteNoContent = Verb 'DELETE 204 -- | 'PATCH' with 204 status code. type PatchNoContent = Verb 'PATCH 204 -- | 'PUT' with 204 status code. type PutNoContent = Verb 'PUT 204 -- ** 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.16.2/src/Servant/API/WithNamedContext.hs0000644000000000000000000000133207346545000020055 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.16.2/src/Servant/Links.hs0000644000000000000000000004600107346545000015301 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links. -- -- Given an API with a few endpoints: -- -- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators -- >>> import Servant.API -- >>> import Servant.Links -- >>> import Data.Proxy -- >>> -- >>> type Hello = "hello" :> Get '[JSON] Int -- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent -- >>> type API = Hello :<|> Bye -- >>> let api = Proxy :: Proxy API -- -- It is possible to generate links that are guaranteed to be within 'API' with -- 'safeLink'. The first argument to 'safeLink' is a type representing the API -- you would like to restrict links to. The second argument is the destination -- endpoint you would like the link to point to, this will need to end with a -- verb like GET or POST. Further arguments may be required depending on the -- type of the endpoint. If everything lines up you will get a 'Link' out the -- other end. -- -- You may omit 'QueryParam's and the like should you not want to provide them, -- but types which form part of the URL path like 'Capture' must be included. -- The reason you may want to omit 'QueryParam's is that safeLink is a bit -- magical: if parameters are included that could take input it will return a -- function that accepts that input and generates a link. This is best shown -- with an example. Here, a link is generated with no parameters: -- -- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int) -- >>> toUrlPiece (safeLink api hello :: Link) -- "hello" -- -- If the API has an endpoint with parameters then we can generate links with -- or without those: -- -- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent) -- >>> toUrlPiece $ safeLink api with (Just "Hubert") -- "bye?name=Hubert" -- -- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent) -- >>> toUrlPiece $ safeLink api without -- "bye" -- -- If you would like create a helper for generating links only within that API, -- you can partially apply safeLink if you specify a correct type signature -- like so: -- -- >>> :set -XConstraintKinds -- >>> :{ -- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) -- >>> => Proxy endpoint -> MkLink endpoint Link -- >>> apiLink = safeLink api -- >>> :} -- -- `safeLink'` allows to make specialise the output: -- -- >>> safeLink' toUrlPiece api without -- "bye" -- -- >>> :{ -- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint) -- >>> => Proxy endpoint -> MkLink endpoint Text -- >>> apiTextLink = safeLink' toUrlPiece api -- >>> :} -- -- >>> apiTextLink without -- "bye" -- -- Attempting to construct a link to an endpoint that does not exist in api -- will result in a type error like this: -- -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent) -- >>> safeLink api bad_link -- ... -- ...Could not deduce... -- ... -- -- This error is essentially saying that the type family couldn't find -- bad_link under api after trying the open (but empty) type family -- `IsElem'` as a last resort. -- -- @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 ) where import Data.List import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>)) import Data.Singletons.Bool (SBool (..), SBoolI (..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as TE import Data.Type.Bool (If) import GHC.TypeLits (KnownSymbol, symbolVal) import Network.URI (URI (..), escapeURIString, isUnreserved) import Prelude () import Prelude.Compat import Servant.API.Alternative ((:<|>) ((:<|>))) import Servant.API.BasicAuth (BasicAuth) import Servant.API.Capture (Capture', CaptureAll) import Servant.API.Description (Description, Summary) import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Generic import Servant.API.Header (Header') import Servant.API.HttpVersion (HttpVersion) import Servant.API.IsSecure (IsSecure) import Servant.API.Modifiers (FoldRequired) import Servant.API.QueryParam (QueryFlag, QueryParam', QueryParams) import Servant.API.Raw (Raw) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody') import Servant.API.Stream (Stream, StreamBody') import Servant.API.Sub (type (:>)) import Servant.API.TypeLevel import Servant.API.Vault (Vault) import Servant.API.Verbs (Verb) import Servant.API.WithNamedContext (WithNamedContext) import Web.HttpApiData -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any -- 'Link' is guaranteed to be part of the mentioned API. data Link = Link { _segments :: [Escaped] , _queryParams :: [Param] } deriving Show newtype Escaped = Escaped String escaped :: String -> Escaped escaped = Escaped . escapeURIString isUnreserved getEscaped :: Escaped -> String getEscaped (Escaped s) = s instance Show Escaped where showsPrec d (Escaped s) = showsPrec d s show (Escaped s) = show s linkSegments :: Link -> [String] linkSegments = map getEscaped . _segments linkQueryParams :: Link -> [Param] linkQueryParams = _queryParams instance ToHttpApiData Link where toHeader = TE.encodeUtf8 . toUrlPiece toUrlPiece l = let uri = linkURI l in Text.pack $ uriPath uri ++ uriQuery uri -- | Query parameter. data Param = SingleParam String Text.Text | ArrayElemParam String Text.Text | FlagParam String deriving Show addSegment :: Escaped -> Link -> Link addSegment seg l = l { _segments = _segments l <> [seg] } addQueryParam :: Param -> Link -> Link addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } -- | Transform 'Link' into 'URI'. -- -- >>> type API = "something" :> Get '[JSON] Int -- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) -- something -- -- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int -- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] -- sum?x[]=1&x[]=2&x[]=3 -- -- >>> type API = "foo/bar" :> Get '[JSON] Int -- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) -- foo%2Fbar -- -- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] () -- >>> let someRoute = Proxy :: Proxy SomeRoute -- >>> safeLink someRoute someRoute "test@example.com" -- Link {_segments = ["abc","test%40example.com"], _queryParams = []} -- -- >>> linkURI $ safeLink someRoute someRoute "test@example.com" -- abc/test%40example.com -- linkURI :: Link -> URI linkURI = linkURI' LinkArrayElementBracket -- | How to encode array query elements. data LinkArrayElementStyle = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@ | LinkArrayElementPlain -- ^ @foo=1&foo=2@ deriving (Eq, Ord, Show, Enum, Bounded) -- | Configurable 'linkURI'. -- -- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int -- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] -- sum?x[]=1&x[]=2&x[]=3 -- -- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3] -- sum?x=1&x=2&x=3 -- linkURI' :: LinkArrayElementStyle -> Link -> URI linkURI' addBrackets (Link segments q_params) = URI mempty -- No scheme (relative) Nothing -- Or authority (relative) (intercalate "/" $ map getEscaped segments) (makeQueries q_params) mempty where makeQueries :: [Param] -> String makeQueries [] = "" makeQueries xs = "?" <> intercalate "&" (fmap makeQuery xs) makeQuery :: Param -> String makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v) makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k style = case addBrackets of LinkArrayElementBracket -> "[]=" LinkArrayElementPlain -> "=" escape :: String -> String escape = escapeURIString isUnreserved -- | Create a valid (by construction) relative URI with query params. -- -- This function will only typecheck if `endpoint` is part of the API `api` safeLink :: forall endpoint api. (IsElem endpoint api, HasLink endpoint) => Proxy api -- ^ The whole API that this endpoint is a part of -> Proxy endpoint -- ^ The API endpoint you would like to point to -> MkLink endpoint Link safeLink = safeLink' id -- | More general 'safeLink'. -- safeLink' :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint) => (Link -> a) -> Proxy api -- ^ The whole API that this endpoint is a part of -> Proxy endpoint -- ^ The API endpoint you would like to point to -> MkLink endpoint a safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty) -- | Create all links in an API. -- -- Note that the @api@ type must be restricted to the endpoints that have -- valid links to them. -- -- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double -- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API) -- >>> :t fooLink -- fooLink :: Text -> Link -- >>> :t barLink -- barLink :: Int -> Link -- -- Note: nested APIs don't work well with this approach -- -- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link -- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: * -- = Char -> (Int -> Link) :<|> (Double -> Link) allLinks :: forall api. HasLink api => Proxy api -> MkLink api Link allLinks = allLinks' id -- | More general 'allLinks'. See `safeLink'`. allLinks' :: forall api a. HasLink api => (Link -> a) -> Proxy api -> MkLink api a allLinks' toA api = toLink toA api (Link mempty mempty) ------------------------------------------------------------------------------- -- 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 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 -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where type MkLink (AuthProtect tag :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) -- | Helper for implemneting 'toLink' for combinators not affecting link -- structure. simpleToLink :: forall sub a combinator. (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a) => Proxy sub -> (Link -> a) -> Proxy (combinator :> sub) -> Link -> MkLink (combinator :> sub) a simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub) -- $setup -- >>> import Servant.API -- >>> import Data.Text (Text) servant-0.16.2/src/Servant/Test/0000755000000000000000000000000007346545000014603 5ustar0000000000000000servant-0.16.2/src/Servant/Test/ComprehensiveAPI.hs0000644000000000000000000000615407346545000020306 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"] "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" :> Verb 'POST 204 '[JSON] NoContent :<|> "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) :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint comprehensiveAPIWithoutStreamingOrRaw :: Proxy ComprehensiveAPIWithoutStreamingOrRaw comprehensiveAPIWithoutStreamingOrRaw = Proxy servant-0.16.2/src/Servant/Types/0000755000000000000000000000000007346545000014770 5ustar0000000000000000servant-0.16.2/src/Servant/Types/SourceT.hs0000644000000000000000000002771407346545000016723 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: >=1.10 -- 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.16.2/src/Servant/Utils/0000755000000000000000000000000007346545000014764 5ustar0000000000000000servant-0.16.2/src/Servant/Utils/Links.hs0000644000000000000000000000021407346545000016375 0ustar0000000000000000module Servant.Utils.Links {-# DEPRECATED "Use Servant.Links." #-} ( module Servant.Links ) where import Servant.Links servant-0.16.2/test/Servant/API/0000755000000000000000000000000007346545000014465 5ustar0000000000000000servant-0.16.2/test/Servant/API/ContentTypesSpec.hs0000644000000000000000000003000307346545000020267 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 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 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.16.2/test/Servant/API/ResponseHeadersSpec.hs0000644000000000000000000000176507346545000020737 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.16.2/test/Servant/API/StreamSpec.hs0000644000000000000000000001046407346545000017074 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 . flip unSourceT 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.16.2/test/Servant/0000755000000000000000000000000007346545000014054 5ustar0000000000000000servant-0.16.2/test/Servant/LinksSpec.hs0000644000000000000000000001214007346545000016301 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.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) import Servant.Links type TestApi = -- Capture and query params "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent :<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent -- Flags :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent -- All of the verbs :<|> "get" :> Get '[JSON] NoContent :<|> "put" :> Put '[JSON] NoContent :<|> "post" :> ReqBody '[JSON] Bool :> Post '[JSON] NoContent :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent :<|> "raw" :> Raw :<|> NoEndpoint type LinkableApi = "all" :> CaptureAll "names" String :> Get '[JSON] NoContent :<|> "get" :> Get '[JSON] NoContent apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint Link apiLink = safeLink (Proxy :: Proxy TestApi) -- | Convert a link to a URI and ensure that this maps to the given string -- given string shouldBeLink :: Link -> String -> Expectation shouldBeLink link expected = toUrlPiece link `shouldBe` fromString expected spec :: Spec spec = describe "Servant.Links" $ do it "generates correct links for capture query params" $ do let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent) apiLink l1 "hi" `shouldBeLink` "hello/hi" let l2 = Proxy :: Proxy ("hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent) apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true" let l4 = Proxy :: Proxy ("hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent) apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false" it "generates correct links for CaptureAll" $ do apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) ["roads", "lead", "to", "rome"] `shouldBeLink` "all/roads/lead/to/rome" it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent) apiLink l1 True True `shouldBeLink` "balls?bouncy&fast" apiLink l1 False True `shouldBeLink` "balls?fast" it "generates correct links for all of the verbs" $ do apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get" apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put" apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post" apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw" it "can generate all links for an API that has only linkable endpoints" $ do let (allNames :<|> simple) = allLinks (Proxy :: Proxy LinkableApi) simple `shouldBeLink` "get" allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius" it "can generate all links for ComprehensiveAPIWithoutRaw" $ do let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw firstLink `shouldBeLink` "" -- | -- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, -- we'll just use doctest -- -- with TypeError comparing for errors is difficult. -- -- >>> apiLink (Proxy :: Proxy WrongPath) -- ... -- ......:...:... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongReturnType) -- ... -- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongContentType) -- ... -- ......:...:... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongMethod) -- ... -- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy NotALink) -- ... -- ...Could not deduce... -- ... -- -- >>> linkURI $ apiLink (Proxy :: Proxy NoEndpoint) -- ... -- ... -- ... -- -- sanity check -- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood) -- "get" type WrongPath = "getTypo" :> Get '[JSON] NoContent type WrongReturnType = "get" :> Get '[JSON] Bool type WrongContentType = "get" :> Get '[OctetStream] NoContent type WrongMethod = "get" :> Post '[JSON] NoContent type NotALink = "hello" :> ReqBody '[JSON] Bool :> Get '[JSON] Bool type AllGood = "get" :> Get '[JSON] NoContent type NoEndpoint = "empty" :> EmptyAPI servant-0.16.2/test/0000755000000000000000000000000007346545000012432 5ustar0000000000000000servant-0.16.2/test/Spec.hs0000644000000000000000000000005407346545000013657 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} servant-0.16.2/test/doctests.hs0000644000000000000000000000157207346545000014623 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, module_sources, pkgs) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources