servant-0.11/0000755000000000000000000000000013111232260011272 5ustar0000000000000000servant-0.11/CHANGELOG.md0000644000000000000000000001045013111232260013103 0ustar00000000000000000.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.11/Setup.lhs0000644000000000000000000000121413111232260013100 0ustar0000000000000000\begin{code} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal #warning You are configuring this package without cabal-doctest installed. \ The doctests test-suite will not work as a result. \ To fix this, install cabal-doctest before configuring. #endif import Distribution.Simple main :: IO () main = defaultMain #endif \end{code} servant-0.11/LICENSE0000644000000000000000000000306113111232260012277 0ustar0000000000000000Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 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.11/servant.cabal0000644000000000000000000001111313111232260013735 0ustar0000000000000000name: servant version: 0.11 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them . You can learn about the basics in the . . homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Servant Web build-type: Custom cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files: include/*.h 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.2 && <1.1 library exposed-modules: Servant.API Servant.API.Alternative Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes Servant.API.Empty Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion Servant.API.Internal.Test.ComprehensiveAPI Servant.API.IsSecure Servant.API.QueryParam Servant.API.Raw Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub Servant.API.TypeLevel Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext Servant.Utils.Links Servant.Utils.Enter build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9 && < 0.10 , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , http-api-data >= 0.3 && < 0.4 , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10 , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3 , mmorph >= 1 && < 1.2 , tagged >= 0.7.3 && < 0.9 , text >= 1 && < 1.3 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 && < 2.7 , vault >= 0.3 && < 0.4 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 && < 0.19 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP , ConstraintKinds , DataKinds , DeriveDataTypeable , FlexibleInstances , FunctionalDependencies , GADTs , KindSignatures , MultiParamTypeClasses , OverlappingInstances , OverloadedStrings , PolyKinds , QuasiQuotes , RecordWildCards , ScopedTypeVariables , TemplateHaskell , TypeFamilies , TypeOperators , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall if impl(ghc >= 8.0) ghc-options: -Wno-redundant-constraints include-dirs: include 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.Utils.LinksSpec Servant.Utils.EnterSpec build-depends: base == 4.* , base-compat , aeson , aeson-compat >=0.3.3 && <0.4 , attoparsec , bytestring , hspec == 2.* , QuickCheck , quickcheck-instances , servant , string-conversions , text , url if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 && < 0.19 test-suite doctests build-depends: base , servant , doctest , filemanip , directory , filepath , hspec type: exitcode-stdio-1.0 main-is: test/doctests.hs buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never include-dirs: include x-doctest-source-dirs: test x-doctest-modules: Servant.Utils.LinksSpec servant-0.11/src/0000755000000000000000000000000013111232260012061 5ustar0000000000000000servant-0.11/src/Servant/0000755000000000000000000000000013111232260013503 5ustar0000000000000000servant-0.11/src/Servant/API.hs0000644000000000000000000001225113111232260014451 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'@ -- * 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, -- * Authentication module Servant.API.BasicAuth, -- * 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 -- * Utilities module Servant.Utils.Links, -- | Type-safe internal URIs ) where import Servant.API.Alternative ((:<|>) (..)) import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) import Servant.API.Capture (Capture, CaptureAll) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, JSON, MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText) import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody) import Servant.API.ResponseHeaders (AddHeader, addHeader, noHeader, BuildHeadersTo (buildHeadersTo), GetHeaders (getHeaders), HList (..), Headers (..), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) import Servant.API.Vault (Vault) import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, GetNonAuthoritative, GetPartialContent, GetResetContent, Patch, PatchAccepted, PatchNoContent, PatchNoContent, PatchNonAuthoritative, Post, PostAccepted, PostNoContent, PostNonAuthoritative, PostResetContent, Put, PutAccepted, PutNoContent, PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb, StdMethod(..)) import Servant.API.WithNamedContext (WithNamedContext) import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) servant-0.11/src/Servant/API/0000755000000000000000000000000013111232260014114 5ustar0000000000000000servant-0.11/src/Servant/API/TypeLevel.hs0000644000000000000000000002113213111232260016360 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, -- * Custom type errors -- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class, -- which cannot be instantiated. ) 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) #if MIN_VERSION_base(4,9,0) import GHC.TypeLits (TypeError, ErrorMessage(..)) #endif -- * 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 #if MIN_VERSION_base(4,9,0) -- Note [Custom Errors] ElemGo x '[] orig = TypeError ('ShowType x ':<>: 'Text " expected in list " ':<>: 'ShowType orig) #else ElemGo x '[] orig = ElemNotFoundIn x orig #endif -- ** Logic -- | If either a or b produce an empty constraint, produce an empty constraint. 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 () () = () -- * Custom type errors #if !MIN_VERSION_base(4,9,0) class ElemNotFoundIn val list #endif {- Note [Custom Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We might try to factor these our more cleanly, but the type synonyms and type families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -} -- $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.11/src/Servant/API/Sub.hs0000644000000000000000000000130413111232260015177 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 9 :> -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data World -- >>> instance ToJSON World where { toJSON = undefined } servant-0.11/src/Servant/API/ReqBody.hs0000644000000000000000000000115313111232260016015 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.ReqBody where import Data.Typeable (Typeable) -- | Extract the request body as a value of type @a@. -- -- Example: -- -- >>> -- POST /books -- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book data ReqBody (contentTypes :: [*]) a deriving (Typeable) -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.11/src/Servant/API/IsSecure.hs0000644000000000000000000000261413111232260016175 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Servant.API.IsSecure ( -- $issecure IsSecure(..) ) where import Data.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.11/src/Servant/API/Raw.hs0000644000000000000000000000133513111232260015203 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.11/src/Servant/API/ContentTypes.hs0000644000000000000000000003611313111232260017113 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 #-} #include "overlapping-compat.h" -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from -- 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 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 Network.HTTP.Media as M import Web.FormUrlEncoded (FromForm, ToForm, urlEncodeAsForm, urlDecodeAsForm) import Prelude () import Prelude.Compat #if MIN_VERSION_base(4,9,0) import qualified GHC.TypeLits as TL #endif -- * Provided content types data JSON deriving Typeable data PlainText deriving Typeable data FormUrlEncoded deriving Typeable data OctetStream deriving Typeable -- * 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 #if MIN_VERSION_base(4,9,0) instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTRender '[] () where handleAcceptH _ _ _ = error "unreachable" #endif -------------------------------------------------------------------------- -- * Unrender -- | 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, \bs -> mimeUnrenderWithType pctyp ct bs) 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) -------------------------------------------------------------------------- -- * 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.11/src/Servant/API/ResponseHeaders.hs0000644000000000000000000001433213111232260017545 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} #include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int -- -- The value is added to the header specified by the type (@Location@ in the -- example above). module Servant.API.ResponseHeaders ( Headers(..) , AddHeader , addHeader , noHeader , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders) , HeaderValMap , HList(..) ) where import Data.ByteString.Char8 as BS (pack, unlines, init) import Web.HttpApiData (ToHttpApiData, toHeader, FromHttpApiData, parseHeader) import qualified Data.CaseInsensitive as CI import Data.Proxy import GHC.TypeLits (KnownSymbol, symbolVal) import qualified Network.HTTP.Types.Header as HTTP import Servant.API.Header (Header (..)) import Prelude () import Prelude.Compat -- | 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) data HList a where HNil :: HList '[] HCons :: Header h x -> HList xs -> HList (Header h x ': xs) 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] instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) ) => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest UndecodableHeader h `HCons` rest -> (headerName, h) :getHeaders rest MissingHeader `HCons` rest -> getHeaders rest where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v ) => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ 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 :: Header 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 -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.11/src/Servant/API/Empty.hs0000644000000000000000000000076513111232260015556 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.11/src/Servant/API/Verbs.hs0000644000000000000000000001337213111232260015537 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.Typeable (Typeable) import Data.Proxy (Proxy) import GHC.Generics (Generic) import GHC.TypeLits (Nat) import Network.HTTP.Types.Method (Method, StdMethod (..), methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, methodTrace, methodConnect, methodOptions) -- | @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 resource cannot be created immediately, use 'PostAccepted'. -- -- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header -- field. -- | 'POST' with 201 status code. -- type PostCreated = Verb 'POST 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.11/src/Servant/API/Vault.hs0000644000000000000000000000101013111232260015533 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.11/src/Servant/API/QueryParam.hs0000644000000000000000000000337613111232260016547 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) where import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) -- | 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] data QueryParam (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.11/src/Servant/API/WithNamedContext.hs0000644000000000000000000000131313111232260017673 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.11/src/Servant/API/Capture.hs0000644000000000000000000000204013111232260016047 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.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 data Capture (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.11/src/Servant/API/Alternative.hs0000644000000000000000000000236513111232260016734 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where 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 8 :<|> 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') -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } servant-0.11/src/Servant/API/HttpVersion.hs0000644000000000000000000000074213111232260016740 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.11/src/Servant/API/Header.hs0000644000000000000000000000162113111232260015640 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Header ( Header(..), ) where import Data.ByteString (ByteString) import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) -- | Extract the given header's value as a value of type @a@. -- -- Example: -- -- >>> newtype Referer = Referer Text deriving (Eq, Show) -- >>> -- >>> -- GET /view-my-referer -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer data Header (sym :: Symbol) a = Header a | MissingHeader | UndecodableHeader ByteString deriving (Typeable, Eq, Show, Functor) -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text servant-0.11/src/Servant/API/RemoteHost.hs0000644000000000000000000000121513111232260016540 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Servant.API.RemoteHost ( -- $remotehost RemoteHost ) where import Data.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.11/src/Servant/API/BasicAuth.hs0000644000000000000000000000226413111232260016317 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.11/src/Servant/API/Experimental/0000755000000000000000000000000013111232260016551 5ustar0000000000000000servant-0.11/src/Servant/API/Experimental/Auth.hs0000644000000000000000000000065413111232260020013 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.11/src/Servant/API/Internal/0000755000000000000000000000000013111232260015670 5ustar0000000000000000servant-0.11/src/Servant/API/Internal/Test/0000755000000000000000000000000013111232260016607 5ustar0000000000000000servant-0.11/src/Servant/API/Internal/Test/ComprehensiveAPI.hs0000644000000000000000000000237213111232260022310 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), and should not be imported. module Servant.API.Internal.Test.ComprehensiveAPI where import Data.Proxy import Servant.API type GET = Get '[JSON] NoContent type ComprehensiveAPI = ComprehensiveAPIWithoutRaw :<|> Raw comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy type ComprehensiveAPIWithoutRaw = GET :<|> Get '[JSON] Int :<|> Capture "foo" Int :> GET :<|> Header "foo" Int :> GET :<|> HttpVersion :> GET :<|> IsSecure :> GET :<|> QueryParam "foo" Int :> GET :<|> QueryParams "foo" Int :> GET :<|> QueryFlag "foo" :> GET :<|> RemoteHost :> GET :<|> ReqBody '[JSON] Int :> GET :<|> Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> "foo" :> GET :<|> Vault :> GET :<|> Verb 'POST 204 '[JSON] NoContent :<|> Verb 'POST 204 '[JSON] Int :<|> WithNamedContext "foo" '[] GET :<|> CaptureAll "foo" Int :> GET :<|> EmptyAPI comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw comprehensiveAPIWithoutRaw = Proxy servant-0.11/src/Servant/Utils/0000755000000000000000000000000013111232260014603 5ustar0000000000000000servant-0.11/src/Servant/Utils/Links.hs0000644000000000000000000002540013111232260016220 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type safe generation of internal links. -- -- Given an API with a few endpoints: -- -- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators -- >>> import Servant.API -- >>> import Servant.Utils.Links -- >>> import Data.Proxy -- >>> -- >>> -- >>> -- >>> type Hello = "hello" :> Get '[JSON] Int -- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent -- >>> type API = Hello :<|> Bye -- >>> let api = Proxy :: Proxy API -- -- It is possible to generate links that are guaranteed to be within 'API' with -- 'safeLink'. The first argument to 'safeLink' is a type representing the API -- you would like to restrict links to. The second argument is the destination -- endpoint you would like the link to point to, this will need to end with a -- verb like GET or POST. Further arguments may be required depending on the -- type of the endpoint. If everything lines up you will get a 'Link' out the -- other end. -- -- You may omit 'QueryParam's and the like should you not want to provide them, -- but types which form part of the URL path like 'Capture' must be included. -- The reason you may want to omit 'QueryParam's is that safeLink is a bit -- magical: if parameters are included that could take input it will return a -- function that accepts that input and generates a link. This is best shown -- with an example. Here, a link is generated with no parameters: -- -- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int) -- >>> toUrlPiece (safeLink api hello :: Link) -- "hello" -- -- If the API has an endpoint with parameters then we can generate links with -- or without those: -- -- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent) -- >>> toUrlPiece $ safeLink api with (Just "Hubert") -- "bye?name=Hubert" -- -- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent) -- >>> toUrlPiece $ safeLink api without -- "bye" -- -- If you would like create a helper for generating links only within that API, -- you can partially apply safeLink if you specify a correct type signature -- like so: -- -- >>> :set -XConstraintKinds -- >>> :{ -- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) -- >>> => Proxy endpoint -> MkLink endpoint -- >>> apiLink = safeLink api -- >>> :} -- -- Attempting to construct a link to an endpoint that does not exist in api -- will result in a type error like this: -- -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent) -- >>> safeLink api bad_link -- ... -- ...Could not deduce... -- ... -- -- This error is essentially saying that the type family couldn't find -- bad_link under api after trying the open (but empty) type family -- `IsElem'` as a last resort. module Servant.Utils.Links ( module Servant.API.TypeLevel, -- * Building and using safe links -- -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. safeLink , URI(..) -- * Adding custom types , HasLink(..) , Link , linkURI , linkURI' , LinkArrayElementStyle (..) -- ** Link accessors , Param (..) , linkSegments , linkQueryParams ) where import Data.List import Data.Monoid.Compat ( (<>) ) import Data.Proxy ( Proxy(..) ) import qualified Data.Text as Text import qualified Data.Text.Encoding as TE import GHC.TypeLits ( KnownSymbol, symbolVal ) import Network.URI ( URI(..), escapeURIString, isUnreserved ) import Prelude () import Prelude.Compat import Web.HttpApiData import Servant.API.BasicAuth ( BasicAuth ) import Servant.API.Capture ( Capture, CaptureAll ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) import Servant.API.RemoteHost ( RemoteHost ) import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.TypeLevel import Servant.API.Experimental.Auth ( AuthProtect ) -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any -- 'Link' is guaranteed to be part of the mentioned API. data Link = Link { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"] , _queryParams :: [Param] } deriving Show linkSegments :: Link -> [String] linkSegments = _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 :: String -> 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 -- 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 escape 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 safeLink _ endpoint = toLink endpoint (Link mempty mempty) -- | Construct a toLink for an endpoint. class HasLink endpoint where type MkLink endpoint toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to -> Link -> MkLink endpoint -- Naked symbol instance instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where type MkLink (sym :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) . addSegment seg where seg = symbolVal (Proxy :: Proxy sym) -- QueryParam instances instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) => HasLink (QueryParam sym v :> sub) where type MkLink (QueryParam sym v :> sub) = Maybe v -> MkLink sub toLink _ l mv = toLink (Proxy :: Proxy sub) $ maybe id (addQueryParam . SingleParam k . toQueryParam) mv l where k :: String k = symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) => HasLink (QueryParams sym v :> sub) where type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub toLink _ l = toLink (Proxy :: Proxy sub) . foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l where k = symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, HasLink sub) => HasLink (QueryFlag sym :> sub) where type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub toLink _ l False = toLink (Proxy :: Proxy sub) l toLink _ l True = toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l where k = symbolVal (Proxy :: Proxy sym) -- Misc instances instance HasLink sub => HasLink (ReqBody ct a :> sub) where type MkLink (ReqBody ct a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) instance (ToHttpApiData v, HasLink sub) => HasLink (Capture sym v :> sub) where type MkLink (Capture sym v :> sub) = v -> MkLink sub toLink _ l v = toLink (Proxy :: Proxy sub) $ addSegment (escape . Text.unpack $ toUrlPiece v) l instance (ToHttpApiData v, HasLink sub) => HasLink (CaptureAll sym v :> sub) where type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub toLink _ l vs = toLink (Proxy :: Proxy sub) $ foldl' (flip $ addSegment . escape . Text.unpack . toUrlPiece) l vs instance HasLink sub => HasLink (Header sym a :> sub) where type MkLink (Header sym a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (RemoteHost :> sub) where type MkLink (RemoteHost :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (BasicAuth realm a :> sub) where type MkLink (BasicAuth realm a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) -- Verb (terminal) instances instance HasLink (Verb m s ct a) where type MkLink (Verb m s ct a) = Link toLink _ = id instance HasLink Raw where type MkLink Raw = Link toLink _ = id -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where type MkLink (AuthProtect tag :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) -- $setup -- >>> import Servant.API servant-0.11/src/Servant/Utils/Enter.hs0000644000000000000000000000755513111232260016230 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Utils.Enter ( module Servant.Utils.Enter, -- * natural-transformation re-exports (:~>)(..), ) where import Control.Natural import Control.Monad.Identity import Control.Monad.Morph import Control.Monad.Reader import qualified Control.Monad.State.Lazy as LState import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter import Data.Tagged (Tagged, retag) import Prelude () import Prelude.Compat import Servant.API -- | Helper type family to state the 'Enter' symmetry. type family Entered m n api where Entered m n (a -> api) = a -> Entered m n api Entered m n (m a) = n a Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2 Entered m n (Tagged m a) = Tagged n a class ( Entered m n typ ~ ret , Entered n m ret ~ typ ) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m where -- | Map the leafs of an API type. enter :: (m :~> n) -> typ -> ret -- ** Servant combinators instance ( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2 , m1 ~ m2, n1 ~ n2 , Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2) , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2) ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2) where enter e (a :<|> b) = enter e a :<|> enter e b instance ( Enter typ m n ret , Entered m n (a -> typ) ~ (a -> ret) , Entered n m (a -> ret) ~ (a -> typ) ) => Enter (a -> typ) m n (a -> ret) where enter arg f a = enter arg (f a) -- ** Leaf instances instance ( Entered m n (Tagged m a) ~ Tagged n a , Entered n m (Tagged n a) ~ Tagged m a ) => Enter (Tagged m a) m n (Tagged n a) where enter _ = retag instance ( Entered m n (m a) ~ n a , Entered n m (n a) ~ m a ) => Enter (m a) m n (n a) where enter (NT f) = f -- | Like `lift`. liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m liftNat = NT Control.Monad.Morph.lift runReaderTNat :: r -> (ReaderT r m :~> m) runReaderTNat a = NT (`runReaderT` a) evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) evalStateTLNat a = NT (`LState.evalStateT` a) evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) evalStateTSNat a = NT (`SState.evalStateT` a) -- | Log the contents of `SWriter.WriterT` with the function provided as the -- first argument, and return the value of the @WriterT@ computation logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m) logWriterTSNat logger = NT $ \x -> do (a, w) <- SWriter.runWriterT x liftIO $ logger w return a -- | Like `logWriterTSNat`, but for lazy @WriterT@. logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) logWriterTLNat logger = NT $ \x -> do (a, w) <- LWriter.runWriterT x liftIO $ logger w return a -- | Like @mmorph@'s `hoist`. hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n) hoistNat (NT n) = NT $ hoist n -- | Like @mmorph@'s `embed`. embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) embedNat (NT n) = NT $ embed n -- | Like @mmorph@'s `squash`. squashNat :: (Monad m, MMonad t) => t (t m) :~> t m squashNat = NT squash -- | Like @mmorph@'s `generalize`. generalizeNat :: Applicative m => Identity :~> m generalizeNat = NT (pure . runIdentity) servant-0.11/include/0000755000000000000000000000000013111232260012715 5ustar0000000000000000servant-0.11/include/overlapping-compat.h0000644000000000000000000000032213111232260016672 0ustar0000000000000000#if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPABLE_ {-# OVERLAPPABLE #-} #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPABLE_ #define OVERLAPPING_ #endif servant-0.11/test/0000755000000000000000000000000013111232260012251 5ustar0000000000000000servant-0.11/test/doctests.hs0000644000000000000000000000147213111232260014441 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, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources servant-0.11/test/Spec.hs0000644000000000000000000000005413111232260013476 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} servant-0.11/test/Servant/0000755000000000000000000000000013111232260013673 5ustar0000000000000000servant-0.11/test/Servant/API/0000755000000000000000000000000013111232260014304 5ustar0000000000000000servant-0.11/test/Servant/API/ResponseHeadersSpec.hs0000644000000000000000000000171713111232260020553 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.11/test/Servant/API/ContentTypesSpec.hs0000644000000000000000000002652713111232260020126 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.Compat import Data.ByteString.Char8 (ByteString, append, pack) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Either import Data.Function (on) import Data.List (maximumBy) 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 Text.Read (readMaybe) import "quickcheck-instances" Test.QuickCheck.Instances () 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 = maximumBy (compare `on` snd) [ ("application/octet-stream", a) , ("application/json;charset=utf-8", b) , ("text/plain;charset=utf-8", c) ] 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 -> 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)) #if MIN_VERSION_aeson(0,9,0) -- 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) #endif 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.11/test/Servant/Utils/0000755000000000000000000000000013111232260014773 5ustar0000000000000000servant-0.11/test/Servant/Utils/EnterSpec.hs0000644000000000000000000000147513111232260017226 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module Servant.Utils.EnterSpec where import Test.Hspec (Spec) import Servant.API import Servant.Utils.Enter ------------------------------------------------------------------------------- -- https://github.com/haskell-servant/servant/issues/734 ------------------------------------------------------------------------------- -- This didn't fail if executed in GHCi; cannot have as a doctest. data App a f :: App :~> App f = NT id server :: App Int :<|> (String -> App Bool) server = undefined server' :: App Int :<|> (String -> App Bool) server' = enter f server ------------------------------------------------------------------------------- -- Spec ------------------------------------------------------------------------------- spec :: Spec spec = return () servant-0.11/test/Servant/Utils/LinksSpec.hs0000644000000000000000000001001613111232260017220 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} module Servant.Utils.LinksSpec where import Data.Proxy (Proxy (..)) import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Data.String (fromString) import Servant.API type TestApi = -- Capture and query params "hello" :> Capture "name" String :> QueryParam "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] 'True :> Post '[JSON] NoContent :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent :<|> "raw" :> Raw :<|> NoEndpoint apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint apiLink = safeLink (Proxy :: Proxy TestApi) -- | Convert a link to a URI and ensure that this maps to the given string -- given string shouldBeLink :: Link -> String -> Expectation shouldBeLink link expected = toUrlPiece link `shouldBe` fromString expected spec :: Spec spec = describe "Servant.Utils.Links" $ do it "generates correct links for capture query params" $ do let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent) apiLink l1 "hi" `shouldBeLink` "hello/hi" let l2 = Proxy :: Proxy ("hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent) apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true" 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" -- | -- 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... -- ... -- -- >>> apiLink (Proxy :: Proxy NoEndpoint) -- ... -- ...No instance for... -- ... -- -- 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] 'True :> Get '[JSON] Bool type AllGood = "get" :> Get '[JSON] NoContent type NoEndpoint = "empty" :> EmptyAPI