servant 0.4.4.7 → 0.5
raw patch · 33 files changed
+972/−584 lines, 33 filesdep +base-compatdep +http-api-datadep +vaultdep −parsecsetup-changed
Dependencies added: base-compat, http-api-data, vault
Dependencies removed: parsec
Files
- LICENSE +1/−1
- Setup.hs +1/−1
- include/overlapping-compat.h +8/−0
- servant.cabal +24/−13
- src/Servant/API.hs +50/−28
- src/Servant/API/Alternative.hs +10/−5
- src/Servant/API/BasicAuth.hs +29/−0
- src/Servant/API/ContentTypes.hs +69/−31
- src/Servant/API/Delete.hs +0/−24
- src/Servant/API/Experimental/Auth.hs +14/−0
- src/Servant/API/Get.hs +0/−22
- src/Servant/API/Header.hs +0/−1
- src/Servant/API/HttpVersion.hs +19/−0
- src/Servant/API/Internal/Test/ComprehensiveAPI.hs +36/−0
- src/Servant/API/IsSecure.hs +37/−0
- src/Servant/API/MatrixParam.hs +0/−51
- src/Servant/API/Patch.hs +0/−29
- src/Servant/API/Post.hs +0/−27
- src/Servant/API/Put.hs +0/−25
- src/Servant/API/Raw.hs +1/−1
- src/Servant/API/RemoteHost.hs +25/−0
- src/Servant/API/ReqBody.hs +0/−1
- src/Servant/API/ResponseHeaders.hs +18/−52
- src/Servant/API/Sub.hs +0/−1
- src/Servant/API/Vault.hs +20/−0
- src/Servant/API/Verbs.hs +169/−0
- src/Servant/API/WithNamedContext.hs +21/−0
- src/Servant/Common/Text.hs +0/−149
- src/Servant/Utils/Links.hs +42/−105
- test/Doctests.hs +28/−17
- test/Servant/API/ContentTypesSpec.hs +225/−0
- test/Servant/API/ResponseHeadersSpec.hs +24/−0
- test/Servant/Utils/LinksSpec.hs +101/−0
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Zalora South East Asia Pte Ltd+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
+ include/overlapping-compat.h view
@@ -0,0 +1,8 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_ {-# OVERLAPPING #-}+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#endif
servant.cabal view
@@ -1,5 +1,5 @@ name: servant-version: 0.4.4.7+version: 0.5 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them@@ -11,11 +11,12 @@ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE-author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni-maintainer: alpmestan@gmail.com-copyright: 2014 Zalora South East Asia Pte Ltd+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple+extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 source-repository head@@ -26,34 +27,39 @@ exposed-modules: Servant.API Servant.API.Alternative+ Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes- Servant.API.Delete- Servant.API.Get+ Servant.API.Experimental.Auth Servant.API.Header- Servant.API.Patch- Servant.API.Post- Servant.API.Put+ Servant.API.HttpVersion+ Servant.API.Internal.Test.ComprehensiveAPI+ Servant.API.IsSecure Servant.API.QueryParam- Servant.API.MatrixParam Servant.API.Raw+ Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub- Servant.Common.Text+ Servant.API.Vault+ Servant.API.Verbs+ Servant.API.WithNamedContext Servant.Utils.Links build-depends:- base >=4.7 && <4.9+ base >=4.7 && <5+ , base-compat >= 0.9 , aeson >= 0.7 , attoparsec >= 0.12 , bytestring == 0.10.* , bytestring-conversion == 0.3.* , case-insensitive >= 1.2+ , http-api-data >= 0.1 && < 0.3 , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10 , text >= 1 && < 2 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6+ , vault >= 0.3 && <0.4 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP@@ -77,6 +83,7 @@ , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall+ include-dirs: include test-suite spec type: exitcode-stdio-1.0@@ -85,6 +92,10 @@ default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs+ other-modules:+ Servant.API.ContentTypesSpec+ Servant.API.ResponseHeadersSpec+ Servant.Utils.LinksSpec build-depends: base == 4.* , aeson@@ -93,7 +104,6 @@ , hspec == 2.* , QuickCheck , quickcheck-instances- , parsec , servant , string-conversions , text@@ -111,3 +121,4 @@ buildable: True default-language: Haskell2010 ghc-options: -threaded+ include-dirs: include
src/Servant/API.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} module Servant.API ( -- * Combinators@@ -14,25 +11,27 @@ -- | Capturing parts of the url path as parsed values: @'Capture'@ 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.MatrixParam,- -- | Retrieving matrix parameters from the 'URI' segment: @'MatrixParam'@+ 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.Get,- -- | @GET@ requests- module Servant.API.Post,- -- | @POST@ requests- module Servant.API.Delete,- -- | @DELETE@ requests- module Servant.API.Put,- -- | @PUT@ requests- module Servant.API.Patch,- -- | @PATCH@ requests+ module Servant.API.Verbs, + -- * Authentication+ module Servant.API.BasicAuth,+ -- * Content Types module Servant.API.ContentTypes, -- | Serializing and deserializing types based on @Accept@ and@@ -45,33 +44,36 @@ module Servant.API.Raw, -- | Plugging in a wai 'Network.Wai.Application', serving directories - -- * FromText and ToText- module Servant.Common.Text,- -- | Classes and instances for types that can be converted to and from @Text@+ -- * 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) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON,- MimeRender (..),+ MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..))-import Servant.API.Delete (Delete)-import Servant.API.Get (Get)+import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Header (Header (..))-import Servant.API.MatrixParam (MatrixFlag, MatrixParam,- MatrixParams)-import Servant.API.Patch (Patch)-import Servant.API.Post (Post)-import Servant.API.Put (Put)+import Servant.API.HttpVersion (HttpVersion (..))+import Servant.API.IsSecure (IsSecure (..)) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw)+import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody) import Servant.API.ResponseHeaders (AddHeader (addHeader), BuildHeadersTo (buildHeadersTo),@@ -79,7 +81,27 @@ HList (..), Headers (..), getHeadersHList, getResponse) import Servant.API.Sub ((:>))-import Servant.Common.Text (FromText (..), ToText (..))+import Servant.API.Vault (Vault)+import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,+ DeleteNoContent,+ DeleteNonAuthoritative, Get,+ GetAccepted, GetNoContent,+ GetNonAuthoritative,+ GetPartialContent,+ GetResetContent,+ Patch,+ PatchAccepted, PatchNoContent,+ PatchNoContent,+ PatchNonAuthoritative, Post,+ PostAccepted, PostNoContent,+ PostNonAuthoritative,+ PostResetContent, Put,+ PutAccepted, PutNoContent,+ PutNoContent, PutNonAuthoritative,+ ReflectMethod (reflectMethod),+ Verb, StdMethod(..))+import Servant.API.WithNamedContext (WithNamedContext) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink)-+import Web.HttpApiData (FromHttpApiData (..),+ ToHttpApiData (..))
src/Servant/API/Alternative.hs view
@@ -1,13 +1,18 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+#if !MIN_VERSION_base(4,8,0)+{-# LANGUAGE DeriveFoldable #-}+#endif+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid (..))-#endif-import Data.Typeable (Typeable)+import Data.Typeable (Typeable)+import Prelude ()+import Prelude.Compat+ -- | Union of two APIs, first takes precedence in case of overlap. -- -- Example:@@ -17,7 +22,7 @@ -- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books -- :} data a :<|> b = a :<|> b- deriving (Typeable, Eq, Show)+ deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) infixr 8 :<|> instance (Monoid a, Monoid b) => Monoid (a :<|> b) where
+ src/Servant/API/BasicAuth.hs view
@@ -0,0 +1,29 @@+{-# 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 <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>.+--+-- *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+ }
src/Servant/API/ContentTypes.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -12,6 +13,8 @@ {-# 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@@ -19,7 +22,7 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: ----- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book+-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> 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@@ -53,25 +56,25 @@ , MimeRender(..) , MimeUnrender(..) + -- * NoContent+ , NoContent(..)+ -- * Internal , AcceptHeader(..) , AllCTRender(..) , AllCTUnrender(..)+ , AllMime(..) , AllMimeRender(..) , AllMimeUnrender(..) , FromFormUrlEncoded(..) , ToFormUrlEncoded(..)- , IsNonEmpty , eitherDecodeLenient+ , canHandleAcceptH ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((*>), (<*))-#endif import Control.Arrow (left)-import Control.Monad-import Data.Aeson (FromJSON, ToJSON, encode,- parseJSON)+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,@@ -80,17 +83,21 @@ import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) import qualified Data.ByteString.Lazy as B-import Data.Monoid+import qualified Data.ByteString.Lazy.Char8 as BC+import Data.Maybe (isJust)+import Data.Monoid.Compat 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.Exts (Constraint)+import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString)+import Prelude ()+import Prelude.Compat -- * Provided content types data JSON deriving Typeable@@ -133,7 +140,7 @@ contentType _ = "application" M.// "octet-stream" newtype AcceptHeader = AcceptHeader BS.ByteString- deriving (Eq, Show)+ deriving (Eq, Show, Read, Typeable, Generic) -- * Render (serializing) @@ -155,20 +162,19 @@ class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -class AllCTRender (list :: [*]) a where+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 ( AllMimeRender ctyps a, IsNonEmpty ctyps- ) => AllCTRender ctyps a where+instance OVERLAPPABLE_+ (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept- where pctyps = Proxy :: Proxy ctyps+ where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs - -------------------------------------------------------------------------- -- * Unrender @@ -196,34 +202,47 @@ class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a -class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where+class AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) -instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps- ) => AllCTUnrender ctyps a where+instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body -------------------------------------------------------------------------- -- * 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 _ = (contentType 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 AllMimeRender (list :: [*]) a where+class (AllMime list) => AllMimeRender (list :: [*]) a where allMimeRender :: Proxy list -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs -instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where+instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)] where pctyp = Proxy :: Proxy ctyp -instance ( MimeRender ctyp a+instance OVERLAPPABLE_+ ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)@@ -232,13 +251,22 @@ pctyps = Proxy :: Proxy (ctyp' ': ctyps) -instance AllMimeRender '[] a where- allMimeRender _ _ = []+-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and+-- then this would be taken care of. However there is no more specific instance+-- between that and 'MimeRender JSON a', so we do this instead+instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where+ allMimeRender _ _ = [(contentType pctyp, "")]+ where pctyp = Proxy :: Proxy ctyp +instance OVERLAPPING_+ ( 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 AllMimeUnrender (list :: [*]) a where+class (AllMime list) => AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list -> ByteString -> [(M.MediaType, Either String a)]@@ -254,21 +282,19 @@ where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps -type family IsNonEmpty (list :: [*]) :: Constraint where- IsNonEmpty (x ': xs) = ()-- -------------------------------------------------------------------------- -- * MimeRender Instances -- | `encode`-instance ToJSON a => MimeRender JSON a where+instance OVERLAPPABLE_+ ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- 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 ToFormUrlEncoded a => MimeRender FormUrlEncoded a where+instance OVERLAPPABLE_+ ToFormUrlEncoded a => MimeRender FormUrlEncoded a where mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded -- | `TextL.encodeUtf8`@@ -279,6 +305,10 @@ 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@@ -287,7 +317,11 @@ instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict +-- | A type for responses without content-body.+data NoContent = NoContent+ deriving (Show, Eq, Read) + -------------------------------------------------------------------------- -- * MimeUnrender Instances @@ -327,6 +361,10 @@ -- | @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
− src/Servant/API/Delete.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# OPTIONS_HADDOCK not-home #-}-module Servant.API.Delete (Delete) where--import Data.Typeable ( Typeable )---- | Combinator for DELETE requests.------ Example:------ >>> -- DELETE /books/:isbn--- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete-data Delete (contentTypes :: [*]) a- deriving Typeable----- $setup--- >>> import Servant.API--- >>> import Data.Aeson--- >>> import Data.Text--- >>> data Book--- >>> instance ToJSON Book where { toJSON = undefined }
+ src/Servant/API/Experimental/Auth.hs view
@@ -0,0 +1,14 @@+{-# 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)+
− src/Servant/API/Get.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# OPTIONS_HADDOCK not-home #-}-module Servant.API.Get (Get) where--import Data.Typeable (Typeable)---- | Endpoint for simple GET requests. Serves the result as JSON.------ Example:------ >>> type MyApi = "books" :> Get '[JSON] [Book]-data Get (contentTypes :: [*]) a- deriving Typeable---- $setup--- >>> import Servant.API--- >>> import Data.Aeson--- >>> import Data.Text--- >>> data Book--- >>> instance ToJSON Book where { toJSON = undefined }
src/Servant/API/Header.hs view
@@ -23,7 +23,6 @@ -- $setup -- >>> import Servant.API--- >>> import Servant.Common.Text -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book
+ src/Servant/API/HttpVersion.hs view
@@ -0,0 +1,19 @@+module 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
+ src/Servant/API/Internal/Test/ComprehensiveAPI.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++-- | This is a module containing an API with all `Servant.API` combinators. It+-- is used for testing only (in particular, checking that instances exist for+-- the core servant classes for each combinator), and should not be imported.+module Servant.API.Internal.Test.ComprehensiveAPI where++import Data.Proxy++import Servant.API++type GET = Get '[JSON] ()++type ComprehensiveAPI =+ GET :<|>+ Get '[JSON] Int :<|>+ Capture "foo" Int :> GET :<|>+ Header "foo" Int :> GET :<|>+ HttpVersion :> GET :<|>+ IsSecure :> GET :<|>+ QueryParam "foo" Int :> GET :<|>+ QueryParams "foo" Int :> GET :<|>+ QueryFlag "foo" :> GET :<|>+-- Raw :<|>+ RemoteHost :> GET :<|>+ ReqBody '[JSON] Int :> GET :<|>+ Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>+ "foo" :> GET :<|>+ Vault :> GET :<|>+ Verb 'POST 204 '[JSON] () :<|>+ Verb 'POST 204 '[JSON] Int :<|>+ WithNamedContext "foo" '[] GET++comprehensiveAPI :: Proxy ComprehensiveAPI+comprehensiveAPI = Proxy
+ src/Servant/API/IsSecure.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Servant.API.IsSecure+ ( -- $issecure+ IsSecure(..)+ ) where++import Data.Typeable++-- | 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 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
− src/Servant/API/MatrixParam.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PolyKinds #-}-{-# OPTIONS_HADDOCK not-home #-}-module Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) where--import Data.Typeable (Typeable)-import GHC.TypeLits (Symbol)--- | Lookup the value associated to the @sym@ matrix string parameter--- and try to extract it as a value of type @a@.------ Example:------ >>> -- /books;author=<author name>--- >>> type MyApi = "books" :> MatrixParam "author" Text :> Get '[JSON] [Book]-data MatrixParam (sym :: Symbol) a- deriving (Typeable)---- | Lookup the values associated to the @sym@ matrix string parameter--- and try to extract it as a value of type @[a]@. This is typically--- meant to support matrix string parameters of the form--- @param[]=val1;param[]=val2@ and so on. Note that servant doesn't actually--- require the @[]@s and will fetch the values just fine with--- @param=val1;param=val2@, too.------ Example:------ >>> -- /books;authors[]=<author1>;authors[]=<author2>;...--- >>> type MyApi = "books" :> MatrixParams "authors" Text :> Get '[JSON] [Book]-data MatrixParams (sym :: Symbol) a- deriving (Typeable)---- | Lookup a potentially value-less matrix 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" :> MatrixFlag "published" :> Get '[JSON] [Book]-data MatrixFlag (sym :: Symbol)- deriving (Typeable)----- $setup--- >>> import Servant.API--- >>> import Data.Aeson--- >>> import Data.Text--- >>> data Book--- >>> instance ToJSON Book where { toJSON = undefined }
− src/Servant/API/Patch.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# OPTIONS_HADDOCK not-home #-}-module Servant.API.Patch (Patch) where--import Data.Typeable (Typeable)---- | Endpoint for PATCH requests. The type variable represents the type of the--- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for--- that).------ If the HTTP response is empty, only () is supported.------ Example:------ >>> -- PATCH /books--- >>> -- with a JSON encoded Book as the request body--- >>> -- returning the just-created Book--- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book-data Patch (contentTypes :: [*]) a- deriving Typeable---- $setup--- >>> import Servant.API--- >>> import Data.Aeson--- >>> import Data.Text--- >>> data Book--- >>> instance ToJSON Book where { toJSON = undefined }
− src/Servant/API/Post.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# OPTIONS_HADDOCK not-home #-}-module Servant.API.Post (Post) where--import Data.Typeable (Typeable)---- | Endpoint for POST requests. The type variable represents the type of the--- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for--- that).------ Example:------ >>> -- POST /books--- >>> -- with a JSON encoded Book as the request body--- >>> -- returning the just-created Book--- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book-data Post (contentTypes :: [*]) a- deriving Typeable---- $setup--- >>> import Servant.API--- >>> import Data.Aeson--- >>> import Data.Text--- >>> data Book--- >>> instance ToJSON Book where { toJSON = undefined }
− src/Servant/API/Put.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures #-}-{-# OPTIONS_HADDOCK not-home #-}-module Servant.API.Put (Put) where--import Data.Typeable ( Typeable )---- | Endpoint for PUT requests, usually used to update a ressource.--- The type @a@ is the type of the response body that's returned.------ Example:------ >>> -- PUT /books/:isbn--- >>> -- with a Book as request body, returning the updated Book--- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book-data Put (contentTypes :: [*]) a- deriving Typeable---- $setup--- >>> import Servant.API--- >>> import Data.Aeson--- >>> import Data.Text--- >>> data Book--- >>> instance ToJSON Book where { toJSON = undefined }
src/Servant/API/Raw.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Raw where -import Data.Typeable (Typeable)+import Data.Typeable (Typeable) -- | Endpoint for plugging in your own Wai 'Application's. -- -- The given 'Application' will get the request as received by the server, potentially with
+ src/Servant/API/RemoteHost.hs view
@@ -0,0 +1,25 @@+{-# 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
src/Servant/API/ReqBody.hs view
@@ -16,7 +16,6 @@ -- $setup -- >>> import Servant.API--- >>> import Servant.Common.Text -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book
src/Servant/API/ResponseHeaders.hs view
@@ -12,11 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances #-}-#endif {-# 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@@ -32,9 +30,6 @@ , HList(..) ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif import Data.ByteString.Char8 as BS (pack, unlines, init) import Data.ByteString.Conversion (ToByteString, toByteString', FromByteString, fromByteString)@@ -44,6 +39,8 @@ 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 'addHeader'.@@ -68,19 +65,12 @@ -- the values are interspersed with commas before deserialization (see -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>) -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- BuildHeadersTo '[] where+instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False- ) => BuildHeadersTo ((Header h v) ': xs) where+instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h+ , Contains h xs ~ 'False)+ => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers@@ -96,38 +86,22 @@ class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- GetHeaders (HList '[]) where+instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)- ) => GetHeaders (HList (Header h x ': xs)) where+instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))+ => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest MissingHeader `HCons` rest -> getHeaders rest where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- GetHeaders (Headers '[] a) where+instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( KnownSymbol h, GetHeaders (HList rest), ToByteString v- ) => GetHeaders (Headers (Header h v ': rest) a) where+instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v)+ => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs -- * Adding@@ -138,21 +112,13 @@ addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False- ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where+instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False)+ => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) -instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- ( KnownSymbol h, ToByteString v- , new ~ (Headers '[Header h v] a)- ) => AddHeader h v a new where+instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v+ , new ~ (Headers '[Header h v] a))+ => AddHeader h v a new where addHeader a resp = Headers resp (HCons (Header a) HNil) type family Contains x xs where
src/Servant/API/Sub.hs view
@@ -20,7 +20,6 @@ -- $setup -- >>> import Servant.API--- >>> import Servant.Common.Text -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data World
+ src/Servant/API/Vault.hs view
@@ -0,0 +1,20 @@+module 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 'Vault' for more details on how to actually+-- use the vault in your handlers+--+-- Example:+--+-- >>> type API = Vault :> Get '[JSON] String++-- $setup+-- >>> import Servant.API
+ src/Servant/API/Verbs.hs view
@@ -0,0 +1,169 @@+{-# 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)++-- | @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+-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC2615> and+-- <https://tools.ietf.org/html/rfc7231#section-6 RFC7231 Section 6>;+-- 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 <https://tools.ietf.org/html/rfc7233#section-4.1+-- RFC7233 Section 4.1>++-- | '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
+ src/Servant/API/WithNamedContext.hs view
@@ -0,0 +1,21 @@+{-# 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
− src/Servant/Common/Text.hs
@@ -1,149 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Servant.Common.Text- ( FromText(..)- , ToText(..)- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Data.Int (Int16, Int32, Int64, Int8)-import Data.String.Conversions (cs)-import Data.Text (Text)-import Data.Text.Read (Reader, decimal, rational, signed)-import Data.Word (Word16, Word32, Word64, Word8-#if !MIN_VERSION_base(4,8,0)- , Word-#endif- )---- | For getting values from url captures and query string parameters--- Instances should obey:--- > fromText (toText a) == Just a-class FromText a where- fromText :: Text -> Maybe a---- | For putting values in paths and query string parameters--- Instances should obey:--- > fromText (toText a) == Just a-class ToText a where- toText :: a -> Text--instance FromText Text where- fromText = Just--instance ToText Text where- toText = id--instance FromText String where- fromText = Just . cs--instance ToText String where- toText = cs---- |--- >>> fromText ("true"::Text) :: Maybe Bool--- Just True--- >>> fromText ("false"::Text) :: Maybe Bool--- Just False--- >>> fromText ("anything else"::Text) :: Maybe Bool--- Nothing-instance FromText Bool where- fromText "true" = Just True- fromText "false" = Just False- fromText _ = Nothing---- |--- >>> toText True--- "true"--- >>> toText False--- "false"-instance ToText Bool where- toText True = "true"- toText False = "false"--instance FromText Int where- fromText = runReader (signed decimal)--instance ToText Int where- toText = cs . show--instance FromText Int8 where- fromText = runReader (signed decimal)--instance ToText Int8 where- toText = cs . show--instance FromText Int16 where- fromText = runReader (signed decimal)--instance ToText Int16 where- toText = cs . show--instance FromText Int32 where- fromText = runReader (signed decimal)--instance ToText Int32 where- toText = cs . show--instance FromText Int64 where- fromText = runReader (signed decimal)--instance ToText Int64 where- toText = cs . show--instance FromText Word where- fromText = runReader decimal--instance ToText Word where- toText = cs . show--instance FromText Word8 where- fromText = runReader decimal--instance ToText Word8 where- toText = cs . show--instance FromText Word16 where- fromText = runReader decimal--instance ToText Word16 where- toText = cs . show--instance FromText Word32 where- fromText = runReader decimal--instance ToText Word32 where- toText = cs . show--instance FromText Word64 where- fromText = runReader decimal--instance ToText Word64 where- toText = cs . show--instance FromText Integer where- fromText = runReader (signed decimal)--instance ToText Integer where- toText = cs . show--instance FromText Double where- fromText x = fromRational <$> runReader rational x--instance ToText Double where- toText = cs . show--instance FromText Float where- -- Double is more practically accurate due to weird rounding when using- -- rational. We convert to double and then convert to Float.- fromText x = fromRational <$> runReader rational x--instance ToText Float where- toText = cs . show--runReader :: Reader a -> Text -> Maybe a-runReader reader t = either (const Nothing) (Just . fst) $ reader t
src/Servant/Utils/Links.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -49,7 +48,7 @@ -- or without those: -- -- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] ())--- >>> print $ safeLink api with "Hubert"+-- >>> print $ safeLink api with (Just "Hubert") -- bye?name=Hubert -- -- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] ())@@ -74,7 +73,7 @@ -- >>> safeLink api bad_link -- ... -- Could not deduce (Or--- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))+-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int)) -- (IsElem' -- ("hello" :> Delete '[JSON] ()) -- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))@@ -101,28 +100,23 @@ , Or ) where -import Data.List-import Data.Proxy ( Proxy(..) )-import Data.Text (Text, unpack)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid ( Monoid(..), (<>) )-#else-import Data.Monoid ( (<>) )-#endif-import Network.URI ( URI(..), escapeURIString, isUnreserved )-import GHC.TypeLits ( KnownSymbol, symbolVal )-import GHC.Exts(Constraint)+import qualified Data.ByteString.Char8 as BSC+import Data.List+import Data.Monoid.Compat ( (<>) )+import Data.Proxy ( Proxy(..) )+import qualified Data.Text as Text+import GHC.Exts (Constraint)+import GHC.TypeLits ( KnownSymbol, symbolVal )+import Network.URI ( URI(..), escapeURIString, isUnreserved )+import Prelude ()+import Prelude.Compat -import Servant.Common.Text+import Web.HttpApiData import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )-import Servant.API.MatrixParam ( MatrixParam, MatrixParams, MatrixFlag ) import Servant.API.Header ( Header )-import Servant.API.Get ( Get )-import Servant.API.Post ( Post )-import Servant.API.Put ( Put )-import Servant.API.Delete ( Delete )+import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.Alternative ( type (:<|>) )@@ -135,6 +129,10 @@ , _queryParams :: [Param Query] } deriving Show +instance ToHttpApiData Link where+ toUrlPiece = Text.pack . show+ toHeader = BSC.pack . show+ -- | If either a or b produce an empty constraint, produce an empty constraint. type family Or (a :: Constraint) (b :: Constraint) :: Constraint where -- This works because of:@@ -165,38 +163,33 @@ 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 x :> sb) = IsElem sa sb+ IsElem sa (Header sym x :> sb) = IsElem sa sb IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem (Capture z y :> sa) (Capture x y :> sb) = IsElem sa sb IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb- IsElem sa (MatrixParam x y :> sb) = IsElem sa sb- IsElem sa (MatrixParams x y :> sb) = IsElem sa sb- IsElem sa (MatrixFlag x :> sb) = IsElem sa sb- IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'- IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'- IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'- IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'+ IsElem (Verb m s ct typ) (Verb m s ct' typ)+ = IsSubList ct ct' IsElem e e = () IsElem e a = IsElem' e a - type family IsSubList a b :: Constraint where IsSubList '[] b = ()- IsSubList '[x] (x ': xs) = ()- IsSubList '[x] (y ': ys) = IsSubList '[x] ys- IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y+ IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y +type family Elem e es :: Constraint where+ Elem x (x ': xs) = ()+ Elem y (x ': xs) = Elem y xs+ -- Phantom types for Param-data Matrix data Query --- | Query/Matrix param+-- | Query param data Param a- = SingleParam String Text- | ArrayElemParam String Text+ = SingleParam String Text.Text+ | ArrayElemParam String Text.Text | FlagParam String deriving Show @@ -207,21 +200,6 @@ addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } --- Not particularly efficient for many updates. Something to optimise if it's--- a problem.-addMatrixParam :: Param Matrix -> Link -> Link-addMatrixParam param l = l { _segments = f (_segments l) }- where- f [] = []- f xs = init xs <> [g (last xs)]- -- Modify the segment at the "top" of the stack- g :: String -> String- g seg =- case param of- SingleParam k v -> seg <> ";" <> k <> "=" <> escape (unpack v)- ArrayElemParam k v -> seg <> ";" <> k <> "[]=" <> escape (unpack v)- FlagParam k -> seg <> ";" <> k- linkURI :: Link -> URI linkURI (Link segments q_params) = URI mempty -- No scheme (relative)@@ -235,8 +213,8 @@ "?" <> intercalate "&" (fmap makeQuery xs) makeQuery :: Param Query -> String- makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (unpack v)- makeQuery (SingleParam k v) = escape k <> "=" <> escape (unpack v)+ makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (Text.unpack v)+ makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k escape :: String -> String@@ -269,22 +247,22 @@ -- QueryParam instances-instance (KnownSymbol sym, ToText v, HasLink sub)+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) => HasLink (QueryParam sym v :> sub) where- type MkLink (QueryParam sym v :> sub) = v -> MkLink sub- toLink _ l v =- toLink (Proxy :: Proxy sub)- (addQueryParam (SingleParam k (toText v)) l)+ 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, ToText v, HasLink sub)+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 (toText v)) l') l+ foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l where k = symbolVal (Proxy :: Proxy sym) @@ -298,66 +276,25 @@ where k = symbolVal (Proxy :: Proxy sym) --- MatrixParam instances-instance (KnownSymbol sym, ToText v, HasLink sub)- => HasLink (MatrixParam sym v :> sub) where- type MkLink (MatrixParam sym v :> sub) = v -> MkLink sub- toLink _ l v =- toLink (Proxy :: Proxy sub) $- addMatrixParam (SingleParam k (toText v)) l- where- k = symbolVal (Proxy :: Proxy sym)--instance (KnownSymbol sym, ToText v, HasLink sub)- => HasLink (MatrixParams sym v :> sub) where- type MkLink (MatrixParams sym v :> sub) = [v] -> MkLink sub- toLink _ l =- toLink (Proxy :: Proxy sub) .- foldl' (\l' v -> addMatrixParam (ArrayElemParam k (toText v)) l') l- where- k = symbolVal (Proxy :: Proxy sym)--instance (KnownSymbol sym, HasLink sub)- => HasLink (MatrixFlag sym :> sub) where- type MkLink (MatrixFlag sym :> sub) = Bool -> MkLink sub- toLink _ l False =- toLink (Proxy :: Proxy sub) l- toLink _ l True =- toLink (Proxy :: Proxy sub) $ addMatrixParam (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 (ToText v, HasLink 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 . unpack $ toText v) l+ addSegment (escape . Text.unpack $ toUrlPiece v) l instance HasLink sub => HasLink (Header sym a :> sub) where type MkLink (Header sym a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) -- Verb (terminal) instances-instance HasLink (Get y r) where- type MkLink (Get y r) = URI- toLink _ = linkURI--instance HasLink (Post y r) where- type MkLink (Post y r) = URI- toLink _ = linkURI--instance HasLink (Put y r) where- type MkLink (Put y r) = URI- toLink _ = linkURI--instance HasLink (Delete y r) where- type MkLink (Delete y r) = URI+instance HasLink (Verb m s ct a) where+ type MkLink (Verb m s ct a) = URI toLink _ = linkURI instance HasLink Raw where
test/Doctests.hs view
@@ -1,6 +1,6 @@ module Main where -import Data.List (isPrefixOf)+import Data.List (isPrefixOf) import System.Directory import System.FilePath import System.FilePath.Find@@ -9,21 +9,32 @@ main :: IO () main = do files <- find always (extension ==? ".hs") "src"- cabalMacrosFile <- getCabalMacrosFile- doctest $ [ "-isrc"- , "-optP-include"- , "-optP" ++ cabalMacrosFile- , "-XOverloadedStrings"- , "-XFlexibleInstances"- , "-XMultiParamTypeClasses"- ] ++ files+ tfiles <- find always (extension ==? ".hs") "test/Servant"+ mCabalMacrosFile <- getCabalMacrosFile+ doctest $ "-isrc" : "-Iinclude" :+ (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) +++ "-XOverloadedStrings" :+ "-XFlexibleInstances" :+ "-XMultiParamTypeClasses" :+ (files ++ tfiles) -getCabalMacrosFile :: IO FilePath+getCabalMacrosFile :: IO (Maybe FilePath) getCabalMacrosFile = do- contents <- getDirectoryContents "dist"- let rest = "build" </> "autogen" </> "cabal_macros.h"- return $ case filter ("dist-sandbox-" `isPrefixOf`) contents of- [x] -> "dist" </> x </> rest- [] -> "dist" </> rest- xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"- ++ show xs ++ "\nTry cabal clean"+ exists <- doesDirectoryExist "dist"+ if exists+ then do+ contents <- getDirectoryContents "dist"+ let rest = "build" </> "autogen" </> "cabal_macros.h"+ whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of+ [x] -> "dist" </> x </> rest+ [] -> "dist" </> rest+ xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"+ ++ show xs ++ "\nTry cabal clean"+ else return Nothing+ where+ whenExists :: FilePath -> IO (Maybe FilePath)+ whenExists file = do+ exists <- doesFileExist file+ return $ if exists+ then Just file+ else Nothing
+ test/Servant/API/ContentTypesSpec.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.API.ContentTypesSpec where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Monoid+#endif+import Control.Arrow+import Data.Aeson+import Data.ByteString.Char8 (ByteString, append, pack)+import qualified Data.ByteString.Lazy as BSL+import Data.Either+import Data.Function (on)+import Data.List (maximumBy)+import Data.Maybe (fromJust, isJust, isNothing)+import Data.Proxy+import Data.String (IsString (..))+import Data.String.Conversions (cs)+import qualified Data.Text as TextS+import qualified Data.Text.Lazy as TextL+import GHC.Generics+import Network.URL (exportParams, importParams)+import Test.Hspec+import Test.QuickCheck+import 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 FormUrlEncoded Content-Type type" $ do+ let p = Proxy :: Proxy FormUrlEncoded++ it "has mimeUnrender reverse mimeRender" $ do+ property $ \x -> mempty `notElem` x+ ==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)])++ it "has mimeUnrender reverse exportParams (Network.URL)" $ do+ property $ \x -> mempty `notElem` x+ ==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])++ it "has importParams (Network.URL) reverse mimeRender" $ do+ property $ \x -> mempty `notElem` x+ ==> (fmap (map (cs *** cs)) . importParams . cs . mimeRender p $ x) == Just (x::[(TextS.Text,TextS.Text)])++ 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 the Content-Type as the first element of the tuple" $ do+ handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)+ `shouldSatisfy` ((== "application/json") . fst . fromJust)+ handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int)+ `shouldSatisfy` ((== "application/json") . fst . fromJust)+ handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream])+ "application/octet-stream" ("content" :: ByteString)+ `shouldSatisfy` ((== "application/octet-stream") . fst . fromJust)++ it "returns the appropriately serialized representation" $ do+ property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData)+ == Just ("application/json", encode x)++ it "respects the Accept spec ordering" $ do+ let highest a b c = maximumBy (compare `on` snd)+ [ ("application/octet-stream", a)+ , ("application/json", 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)++#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++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
+ test/Servant/API/ResponseHeadersSpec.hs view
@@ -0,0 +1,24 @@+{-# 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")]
+ test/Servant/Utils/LinksSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+module Servant.Utils.LinksSpec where++import Data.Proxy (Proxy (..))+import Test.Hspec (Expectation, Spec, describe, it,+ shouldBe)++import Servant.API++type TestApi =+ -- Capture and query params+ "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] ()++ -- Flags+ :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] ()++ -- All of the verbs+ :<|> "get" :> Get '[JSON] ()+ :<|> "put" :> Put '[JSON] ()+ :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] ()+ :<|> "delete" :> Header "ponies" String :> Delete '[JSON] ()+ :<|> "raw" :> Raw+++apiLink :: (IsElem endpoint TestApi, HasLink endpoint)+ => Proxy endpoint -> MkLink endpoint+apiLink = safeLink (Proxy :: Proxy TestApi)++-- | Convert a link to a URI and ensure that this maps to the given string+-- given string+shouldBeURI :: URI -> String -> Expectation+shouldBeURI link expected =+ show link `shouldBe` expected++spec :: Spec+spec = describe "Servant.Utils.Links" $ do+ it "generates correct links for capture query params" $ do+ let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ())+ apiLink l1 "hi" `shouldBeURI` "hello/hi"++ let l2 = Proxy :: Proxy ("hello" :> Capture "name" String+ :> QueryParam "capital" Bool+ :> Delete '[JSON] ())+ apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"+++ it "generates correct links for query flags" $ do+ let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"+ :> QueryFlag "fast" :> Delete '[JSON] ())+ apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"+ apiLink l1 False True `shouldBeURI` "balls?fast"++ it "generates correct links for all of the verbs" $ do+ apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get"+ apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"+ apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"+ apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete"+ apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"+++-- |+-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,+-- we'll just use doctest+--+-- >>> apiLink (Proxy :: Proxy WrongPath)+-- ...+-- Could not deduce ...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongReturnType)+-- ...+-- Could not deduce ...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongContentType)+-- ...+-- Could not deduce ...+-- ...+--+-- >>> apiLink (Proxy :: Proxy WrongMethod)+-- ...+-- Could not deduce ...+-- ...+--+-- >>> apiLink (Proxy :: Proxy NotALink)+-- ...+-- Could not deduce ...+-- ...+--+-- sanity check+-- >>> apiLink (Proxy :: Proxy AllGood)+-- get+type WrongPath = "getTypo" :> Get '[JSON] ()+type WrongReturnType = "get" :> Get '[JSON] Bool+type WrongContentType = "get" :> Get '[OctetStream] ()+type WrongMethod = "get" :> Post '[JSON] ()+type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool+type AllGood = "get" :> Get '[JSON] ()