diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md new file mode 100644 index 00000000..9e7f1090 --- /dev/null +++ b/servant-client/CHANGELOG.md @@ -0,0 +1,15 @@ +0.3 +--- +* Support content-type aware combinators and `Accept`/`Content-type` headers +* Added a lot of tests +* Support multiple concurrent threads +* Use `ServantError` to report Errors instead of `String` +* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example) +* Support for PATCH +* Make () instances expect No Content status code, and not try to decode body. +* `Canonicalize` API types before generating client functions for them + +0.2.2 +----- +* Add TLS support +* Add matrix parameter support diff --git a/servant-client/LICENSE b/servant-client/LICENSE new file mode 100644 index 00000000..bfee8018 --- /dev/null +++ b/servant-client/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Zalora South East Asia Pte Ltd + +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. diff --git a/servant-client/README.md b/servant-client/README.md new file mode 100644 index 00000000..b8ec46a5 --- /dev/null +++ b/servant-client/README.md @@ -0,0 +1,23 @@ +# servant-client + +[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-client.svg)](http://travis-ci.org/haskell-servant/servant-client) +[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant-client/badge.svg)](https://coveralls.io/r/haskell-servant/servant-client) + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. + +## Example + +``` haskell +type MyApi = "books" :> Get [Book] -- GET /books + :<|> "books" :> ReqBody Book :> Post Book -- POST /books + +myApi :: Proxy MyApi +myApi = Proxy + +getAllBooks :: BaseUrl -> EitherT String IO [Book] +postNewBook :: Book -> BaseUrl -> EitherT String IO Book +-- 'client' allows you to produce operations to query an API from a client. +(getAllBooks :<|> postNewBook) = client myApi +``` \ No newline at end of file diff --git a/servant-client/Setup.hs b/servant-client/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-client/docs.sh b/servant-client/docs.sh new file mode 100644 index 00000000..a4f6827e --- /dev/null +++ b/servant-client/docs.sh @@ -0,0 +1,52 @@ +SERVANT_DIR=/tmp/servant-client-gh-pages + +# Make a temporary clone + +rm -rf $SERVANT_DIR + +git clone . $SERVANT_DIR + +cd $SERVANT_DIR + +# Make sure to pull the latest + +git remote add haskell-servant git@github.com:haskell-servant/servant-client.git + +git fetch haskell-servant + +git reset --hard haskell-servant/gh-pages + +# Clear everything away + +git rm -rf $SERVANT_DIR/* + +# Switch back and build the haddocks + +cd - + +cabal configure --builddir=$SERVANT_DIR + +cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR + +commit_hash=$(git rev-parse HEAD) + +# Move the HTML docs to the root + +cd $SERVANT_DIR + +rm * +rm -rf build +mv doc/html/servant-client/* . +rm -r doc/ + +# Add everything + +git add . + +git commit -m "Built from $commit_hash" + +# Push to update the pages + +git push haskell-servant HEAD:gh-pages + +rm -rf $SERVANT_DIR diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal new file mode 100644 index 00000000..512b64bd --- /dev/null +++ b/servant-client/servant-client.cabal @@ -0,0 +1,85 @@ +name: servant-client +version: 0.2.2 +synopsis: automatical derivation of querying functions for servant webservices +description: + This library lets you derive automatically Haskell functions that + let you query each endpoint of a webservice. + . + Example below. + . + > type MyApi = "books" :> Get [Book] -- GET /books + > :<|> "books" :> ReqBody Book :> Post Book -- POST /books + > + > myApi :: Proxy MyApi + > myApi = Proxy + > + > getAllBooks :: BaseUrl -> EitherT String IO [Book] + > postNewBook :: Book -> BaseUrl -> EitherT String IO Book + > (getAllBooks :<|> postNewBook) = client myApi +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 +category: Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.8 +homepage: http://haskell-servant.github.io/ +Bug-reports: http://github.com/haskell-servant/servant-client/issues +source-repository head + type: git + location: http://github.com/haskell-servant/servant-client.git + +library + exposed-modules: + Servant.Client + Servant.Common.BaseUrl + Servant.Common.Req + build-depends: + base >=4.7 && <5 + , aeson + , attoparsec + , bytestring + , either + , exceptions + , http-client + , http-client-tls + , http-media + , http-types + , network-uri >= 2.6 + , safe + , servant >= 0.2.2 + , string-conversions + , text + , transformers + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base == 4.* + , aeson + , bytestring + , deepseq + , either + , hspec == 2.* + , http-client + , http-media + , http-types + , HUnit + , network >= 2.6 + , QuickCheck >= 2.7 + , servant >= 0.2.1 + , servant-client + , servant-server >= 0.2.1 + , text + , wai + , warp diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs new file mode 100644 index 00000000..c50b5471 --- /dev/null +++ b/servant-client/src/Servant/Client.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides 'client' which can automatically generate +-- querying functions for each endpoint just from the type representing your +-- API. +module Servant.Client + ( client + , HasClient(..) + , Client + , ServantError(..) + , module Servant.Common.BaseUrl + ) where + +import Control.Monad +import Control.Monad.Trans.Either +import Data.ByteString.Lazy (ByteString) +import Data.List +import Data.Proxy +import Data.String.Conversions +import Data.Text (unpack) +import GHC.TypeLits +import Network.HTTP.Client (Response) +import Network.HTTP.Media +import qualified Network.HTTP.Types as H +import Servant.API +import Servant.API.ContentTypes +import Servant.Common.BaseUrl +import Servant.Common.Req + +-- * Accessing APIs as a Client + +-- | 'client' allows you to produce operations to query an API from a client. +-- +-- > type MyApi = "books" :> Get [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: BaseUrl -> EitherT String IO [Book] +-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi +client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout +client p = clientWithRoute (canonicalize p) defReq + +-- | This class lets us define how each API combinator +-- influences the creation of an HTTP request. It's mostly +-- an internal class, you can just use 'client'. +class HasClient layout where + type Client' layout :: * + clientWithRoute :: Proxy layout -> Req -> Client' layout + +type Client layout = Client' (Canonicalize layout) + +-- | A client querying function for @a ':<|>' b@ will actually hand you +-- one function for querying @a@ and another one for querying @b@, +-- stitching them together with ':<|>', which really is just like a pair. +-- +-- > type MyApi = "books" :> Get [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: BaseUrl -> EitherT String IO [Book] +-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi +instance (HasClient a, HasClient b) => HasClient (a :<|> b) where + type Client' (a :<|> b) = Client' a :<|> Client' b + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req + +-- | If you use a 'Capture' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Capture'. +-- That function will take care of inserting a textual representation +-- of this value at the right place in the request path. +-- +-- You can control how values for this type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> BaseUrl -> EitherT String IO Book +-- > getBook = client myApi +-- > -- then you can just use "getBook" to query that endpoint +instance (KnownSymbol capture, ToText a, HasClient sublayout) + => HasClient (Capture capture a :> sublayout) where + + type Client' (Capture capture a :> sublayout) = + a -> Client' sublayout + + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToPath p req + + where p = unpack (toText val) + +-- | If you have a 'Delete' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance HasClient Delete where + type Client' Delete = BaseUrl -> EitherT ServantError IO () + + clientWithRoute Proxy req host = + void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host + +-- | If you have a 'Get' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where + type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result + clientWithRoute Proxy req host = + performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host + +-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance HasClient (Get (ct ': cts) ()) where + type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + clientWithRoute Proxy req host = + performRequestNoBody H.methodGet req [204] host + +-- | If you use a 'Header' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Header', +-- wrapped in Maybe. +-- +-- That function will take care of encoding this argument as Text +-- in the request headers. +-- +-- All you need is for your type to have a 'ToText' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer Text +-- > deriving (Eq, Show, FromText, ToText) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> BaseUrl -> EitherT String IO Book +-- > viewReferer = client myApi +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or Just "http://haskell.org/" as arguments +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (Header sym a :> sublayout) where + + type Client' (Header sym a :> sublayout) = + Maybe a -> Client' sublayout + + clientWithRoute Proxy req mval = + clientWithRoute (Proxy :: Proxy sublayout) $ + maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval + + where hname = symbolVal (Proxy :: Proxy sym) + +-- | If you have a 'Post' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where + type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + + clientWithRoute Proxy req uri = + performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri + +-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance HasClient (Post (ct ': cts) ()) where + type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + clientWithRoute Proxy req host = + void $ performRequestNoBody H.methodPost req [204] host + +-- | If you have a 'Put' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where + type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + + clientWithRoute Proxy req host = + performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host + +-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance HasClient (Put (ct ': cts) ()) where + type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + clientWithRoute Proxy req host = + void $ performRequestNoBody H.methodPut req [204] host + +-- | If you have a 'Patch' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where + type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a + + clientWithRoute Proxy req host = + performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host + +-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance HasClient (Patch (ct ': cts) ()) where + type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () + clientWithRoute Proxy req host = + void $ performRequestNoBody H.methodPatch req [204] host + +-- | If you use a 'QueryParam' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'QueryParam', +-- enclosed in Maybe. +-- +-- If you give Nothing, nothing will be added to the query string. +-- +-- If you give a non-'Nothing' value, this function will take care +-- of inserting a textual representation of this value in the query string. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy Nothing' for all books +-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (QueryParam sym a :> sublayout) where + + type Client' (QueryParam sym a :> sublayout) = + Maybe a -> Client' sublayout + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute Proxy req mparam = + clientWithRoute (Proxy :: Proxy sublayout) $ + maybe req (flip (appendToQueryString pname) req . Just) mparamText + + where pname = cs pname' + pname' = symbolVal (Proxy :: Proxy sym) + mparamText = fmap toText mparam + +-- | If you use a 'QueryParams' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument, a list of values of the type specified +-- by your 'QueryParams'. +-- +-- If you give an empty list, nothing will be added to the query string. +-- +-- Otherwise, this function will take care +-- of inserting a textual representation of your values in the query string, +-- under the same query string parameter name. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy []' for all books +-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' +-- > -- to get all books by Asimov and Heinlein +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (QueryParams sym a :> sublayout) where + + type Client' (QueryParams sym a :> sublayout) = + [a] -> Client' sublayout + + clientWithRoute Proxy req paramlist = + clientWithRoute (Proxy :: Proxy sublayout) $ + foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' + + where pname = cs pname' + pname' = symbolVal (Proxy :: Proxy sym) + paramlist' = map (Just . toText) paramlist + +-- | If you use a 'QueryFlag' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional 'Bool' argument. +-- +-- If you give 'False', nothing will be added to the query string. +-- +-- Otherwise, this function will insert a value-less query string +-- parameter under the name associated to your 'QueryFlag'. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book] +-- > getBooks = client myApi +-- > -- then you can just use "getBooks" to query that endpoint. +-- > -- 'getBooksBy False' for all books +-- > -- 'getBooksBy True' to only get _already published_ books +instance (KnownSymbol sym, HasClient sublayout) + => HasClient (QueryFlag sym :> sublayout) where + + type Client' (QueryFlag sym :> sublayout) = + Bool -> Client' sublayout + + clientWithRoute Proxy req flag = + clientWithRoute (Proxy :: Proxy sublayout) $ + if flag + then appendToQueryString paramname Nothing req + else req + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + +-- | If you use a 'MatrixParam' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'MatrixParam', +-- enclosed in Maybe. +-- +-- If you give Nothing, nothing will be added to the query string. +-- +-- If you give a non-'Nothing' value, this function will take care +-- of inserting a textual representation of this value in the query string. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy Nothing' for all books +-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (MatrixParam sym a :> sublayout) where + + type Client' (MatrixParam sym a :> sublayout) = + Maybe a -> Client' sublayout + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute Proxy req mparam = + clientWithRoute (Proxy :: Proxy sublayout) $ + maybe req (flip (appendToMatrixParams pname . Just) req) mparamText + + where pname = symbolVal (Proxy :: Proxy sym) + mparamText = fmap (cs . toText) mparam + +-- | If you use a 'MatrixParams' in one of your endpoints in your API, +-- the corresponding querying function will automatically take an +-- additional argument, a list of values of the type specified by your +-- 'MatrixParams'. +-- +-- If you give an empty list, nothing will be added to the query string. +-- +-- Otherwise, this function will take care of inserting a textual +-- representation of your values in the path segment string, under the +-- same matrix string parameter name. +-- +-- You can control how values for your type are turned into text by +-- specifying a 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy []' for all books +-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' +-- > -- to get all books by Asimov and Heinlein +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (MatrixParams sym a :> sublayout) where + + type Client' (MatrixParams sym a :> sublayout) = + [a] -> Client' sublayout + + clientWithRoute Proxy req paramlist = + clientWithRoute (Proxy :: Proxy sublayout) $ + foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) req paramlist' + + where pname = cs pname' + pname' = symbolVal (Proxy :: Proxy sym) + paramlist' = map (Just . toText) paramlist + +-- | If you use a 'MatrixFlag' in one of your endpoints in your API, +-- the corresponding querying function will automatically take an +-- additional 'Bool' argument. +-- +-- If you give 'False', nothing will be added to the path segment. +-- +-- Otherwise, this function will insert a value-less matrix parameter +-- under the name associated to your 'MatrixFlag'. +-- +-- Example: +-- +-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book] +-- > getBooks = client myApi +-- > -- then you can just use "getBooks" to query that endpoint. +-- > -- 'getBooksBy False' for all books +-- > -- 'getBooksBy True' to only get _already published_ books +instance (KnownSymbol sym, HasClient sublayout) + => HasClient (MatrixFlag sym :> sublayout) where + + type Client' (MatrixFlag sym :> sublayout) = + Bool -> Client' sublayout + + clientWithRoute Proxy req flag = + clientWithRoute (Proxy :: Proxy sublayout) $ + if flag + then appendToMatrixParams paramname Nothing req + else req + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + +-- | Pick a 'Method' and specify where the server you want to query is. You get +-- back the full `Response`. +instance HasClient Raw where + type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) + + clientWithRoute :: Proxy Raw -> Req -> Client' Raw + clientWithRoute Proxy req httpMethod host = do + performRequest httpMethod req (const True) host + +-- | If you use a 'ReqBody' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'ReqBody'. +-- That function will take care of encoding this argument as JSON and +-- of using it as the request body. +-- +-- All you need is for your type to have a 'ToJSON' instance. +-- +-- Example: +-- +-- > type MyApi = "books" :> ReqBody Book :> Post Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > addBook :: Book -> BaseUrl -> EitherT String IO Book +-- > addBook = client myApi +-- > -- then you can just use "addBook" to query that endpoint +instance (MimeRender ct a, HasClient sublayout) + => HasClient (ReqBody (ct ': cts) a :> sublayout) where + + type Client' (ReqBody (ct ': cts) a :> sublayout) = + a -> Client' sublayout + + clientWithRoute Proxy req body = + clientWithRoute (Proxy :: Proxy sublayout) $ do + let ctProxy = Proxy :: Proxy ct + setRQBody (mimeRender ctProxy body) (contentType ctProxy) req + +-- | Make the querying function append @path@ to the request path. +instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where + type Client' (path :> sublayout) = Client' sublayout + + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToPath p req + + where p = symbolVal (Proxy :: Proxy path) + diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs new file mode 100644 index 00000000..eae87c42 --- /dev/null +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} +module Servant.Common.BaseUrl where + +import Data.List +import GHC.Generics +import Network.URI +import Safe +import Text.Read + +-- | URI scheme to use +data Scheme = + Http -- ^ http:// + | Https -- ^ https:// + deriving (Show, Eq, Ord, Generic) + +-- | Simple data type to represent the target of HTTP requests +-- for servant's automatically-generated clients. +data BaseUrl = BaseUrl + { baseUrlScheme :: Scheme -- ^ URI scheme to use + , baseUrlHost :: String -- ^ host (eg "haskell.org") + , baseUrlPort :: Int -- ^ port (eg 80) + } deriving (Show, Eq, Ord, Generic) + +showBaseUrl :: BaseUrl -> String +showBaseUrl (BaseUrl urlscheme host port) = + schemeString ++ "//" ++ host ++ portString + where + schemeString = case urlscheme of + Http -> "http:" + Https -> "https:" + portString = case (urlscheme, port) of + (Http, 80) -> "" + (Https, 443) -> "" + _ -> ":" ++ show port + +parseBaseUrl :: String -> Either String BaseUrl +parseBaseUrl s = case parseURI (removeTrailingSlash s) of + -- This is a rather hacky implementation and should be replaced with something + -- implemented in attoparsec (which is already a dependency anyhow (via aeson)). + Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> + Right (BaseUrl Http host port) + Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> + Right (BaseUrl Http host 80) + Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> + Right (BaseUrl Https host port) + Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> + Right (BaseUrl Https host 443) + _ -> if "://" `isInfixOf` s + then Left ("invalid base url: " ++ s) + else parseBaseUrl ("http://" ++ s) + where + removeTrailingSlash str = case lastMay str of + Just '/' -> init str + _ -> str diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs new file mode 100644 index 00000000..60c53eb8 --- /dev/null +++ b/servant-client/src/Servant/Common/Req.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.Common.Req where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) +import Data.IORef +import Data.String +import Data.String.Conversions +import Data.Proxy +import Data.Text (Text) +import Data.Text.Encoding +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client.TLS +import Network.HTTP.Media +import Network.HTTP.Types +import Network.URI +import Servant.API.ContentTypes +import Servant.Common.BaseUrl +import Servant.Common.Text +import System.IO.Unsafe + +import qualified Network.HTTP.Client as Client + +data ServantError + = FailureResponse + { responseStatus :: Status + , responseContentType :: MediaType + , responseBody :: ByteString + } + | DecodeFailure + { decodeError :: String + , responseContentType :: MediaType + , responseBody :: ByteString + } + | UnsupportedContentType + { responseContentType :: MediaType + , responseBody :: ByteString + } + | ConnectionError + { connectionError :: HttpException + } + | InvalidContentTypeHeader + { responseContentTypeHeader :: ByteString + , responseBody :: ByteString + } + deriving (Show) + +data Req = Req + { reqPath :: String + , qs :: QueryText + , reqBody :: Maybe (ByteString, MediaType) + , reqAccept :: [MediaType] + , headers :: [(String, Text)] + } + +defReq :: Req +defReq = Req "" [] Nothing [] [] + +appendToPath :: String -> Req -> Req +appendToPath p req = + req { reqPath = reqPath req ++ "/" ++ p } + +appendToMatrixParams :: String + -> Maybe String + -> Req + -> Req +appendToMatrixParams pname pvalue req = + req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue } + +appendToQueryString :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> Req + -> Req +appendToQueryString pname pvalue req = + req { qs = qs req ++ [(pname, pvalue)] + } + +addHeader :: ToText a => String -> a -> Req -> Req +addHeader name val req = req { headers = headers req + ++ [(name, toText val)] + } + +setRQBody :: ByteString -> MediaType -> Req -> Req +setRQBody b t req = req { reqBody = Just (b, t) } + +reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request +reqToRequest req (BaseUrl reqScheme reqHost reqPort) = + fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url + + where url = show $ nullURI { uriScheme = case reqScheme of + Http -> "http:" + Https -> "https:" + , uriAuthority = Just $ + URIAuth { uriUserInfo = "" + , uriRegName = reqHost + , uriPort = ":" ++ show reqPort + } + , uriPath = reqPath req + } + + setrqb r = case reqBody req of + Nothing -> r + Just (b,t) -> r { requestBody = RequestBodyLBS b + , requestHeaders = requestHeaders r + ++ [(hContentType, cs . show $ t)] } + setQS = setQueryString $ queryTextToQuery (qs req) + setheaders r = r { requestHeaders = requestHeaders r + <> fmap toProperHeader (headers req) } + setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r) + <> [("Accept", renderHeader $ reqAccept req) + | not . null . reqAccept $ req] } + toProperHeader (name, val) = + (fromString name, encodeUtf8 val) + + +-- * performing requests + +{-# NOINLINE __manager #-} +__manager :: IORef Manager +__manager = unsafePerformIO (newManager tlsManagerSettings >>= newIORef) + +__withGlobalManager :: (Manager -> IO a) -> IO a +__withGlobalManager action = readIORef __manager >>= action + + +displayHttpRequest :: Method -> String +displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" + + +performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString) +performRequest reqMethod req isWantedStatus reqHost = do + partialRequest <- liftIO $ reqToRequest req reqHost + + let request = partialRequest { Client.method = reqMethod + , checkStatus = \ _status _headers _cookies -> Nothing + } + + eResponse <- liftIO $ __withGlobalManager $ \ manager -> + catchHttpException $ + Client.httpLbs request manager + case eResponse of + Left err -> + left $ ConnectionError err + + Right response -> do + let status = Client.responseStatus response + body = Client.responseBody response + status_code = statusCode status + ct <- case lookup "Content-Type" $ Client.responseHeaders response of + Nothing -> pure $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> left $ InvalidContentTypeHeader (cs t) body + Just t' -> pure t' + unless (isWantedStatus status_code) $ + left $ FailureResponse status ct body + return (status_code, body, ct, response) + +performRequestCT :: MimeUnrender ct result => + Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result +performRequestCT ct reqMethod req wantedStatus reqHost = do + let acceptCT = contentType ct + (_status, respBody, respCT, _response) <- + performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost + unless (matches respCT (acceptCT)) $ + left $ UnsupportedContentType respCT respBody + either + (left . (\s -> DecodeFailure s respCT respBody)) + return + (mimeUnrender ct respBody) + +performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO () +performRequestNoBody reqMethod req wantedStatus reqHost = do + _ <- performRequest reqMethod req (`elem` wantedStatus) reqHost + return () + +catchHttpException :: IO a -> IO (Either HttpException a) +catchHttpException action = + catch (Right <$> action) (pure . Left) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs new file mode 100644 index 00000000..ff043ab1 --- /dev/null +++ b/servant-client/test/Servant/ClientSpec.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fcontext-stack=25 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.ClientSpec where + +import Control.Applicative +import qualified Control.Arrow as Arrow +import Control.Concurrent +import Control.Exception +import Control.Monad.Trans.Either +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Char +import Data.Foldable (forM_) +import Data.Monoid +import Data.Proxy +import qualified Data.Text as T +import GHC.Generics +import qualified Network.HTTP.Client as C +import Network.HTTP.Media +import Network.HTTP.Types +import Network.Socket +import Network.Wai hiding (Response) +import Network.Wai.Handler.Warp +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.HUnit +import Test.QuickCheck + +import Servant.API +import Servant.Client +import Servant.Server + +-- * test data types + +data Person = Person { + name :: String, + age :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Person +instance FromJSON Person + +instance ToFormUrlEncoded Person where + toFormUrlEncoded Person{..} = + [("name", T.pack name), ("age", T.pack (show age))] + +lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b +lookupEither x xs = do + maybe (Left $ "could not find key " <> show x) return $ lookup x xs + +instance FromFormUrlEncoded Person where + fromFormUrlEncoded xs = do + n <- lookupEither "name" xs + a <- lookupEither "age" xs + return $ Person (T.unpack n) (read $ T.unpack a) + +deriving instance Eq ServantError + +instance Eq C.HttpException where + a == b = show a == show b + +alice :: Person +alice = Person "Alice" 42 + +type Api = + "get" :> Get '[JSON] Person + :<|> "delete" :> Delete + :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person + :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person + :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person + :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] + :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool + :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person + :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person] + :<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool + :<|> "rawSuccess" :> Raw + :<|> "rawFailure" :> Raw + :<|> "multiple" :> + Capture "first" String :> + QueryParam "second" Int :> + QueryFlag "third" :> + ReqBody '[JSON] [(String, [Rational])] :> + Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) +api :: Proxy Api +api = Proxy + +server :: Application +server = serve api ( + return alice + :<|> return () + :<|> (\ name -> return $ Person name 0) + :<|> return + :<|> (\ name -> case name of + Just "alice" -> return alice + Just name -> left (400, name ++ " not found") + Nothing -> left (400, "missing parameter")) + :<|> (\ names -> return (zipWith Person names [0..])) + :<|> return + :<|> (\ name -> case name of + Just "alice" -> return alice + Just name -> left (400, name ++ " not found") + Nothing -> left (400, "missing parameter")) + :<|> (\ names -> return (zipWith Person names [0..])) + :<|> return + :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") + :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") + :<|> \ a b c d -> return (a, b, c, d) + ) + +withServer :: (BaseUrl -> IO a) -> IO a +withServer action = withWaiDaemon (return server) action + +getGet :: BaseUrl -> EitherT ServantError IO Person +getDelete :: BaseUrl -> EitherT ServantError IO () +getCapture :: String -> BaseUrl -> EitherT ServantError IO Person +getBody :: Person -> BaseUrl -> EitherT ServantError IO Person +getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person +getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person] +getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool +getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person +getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person] +getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool +getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString) +getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString) +getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] + -> BaseUrl + -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])]) +( getGet + :<|> getDelete + :<|> getCapture + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getMatrixParam + :<|> getMatrixParams + :<|> getMatrixFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple) + = client api + +type FailApi = + "get" :> Raw + :<|> "capture" :> Capture "name" String :> Raw + :<|> "body" :> Raw +failApi :: Proxy FailApi +failApi = Proxy + +failServer :: Application +failServer = serve failApi ( + (\ _request respond -> respond $ responseLBS ok200 [] "") + :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") + :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") + ) + +withFailServer :: (BaseUrl -> IO a) -> IO a +withFailServer action = withWaiDaemon (return failServer) action + +spec :: Spec +spec = do + it "Servant.API.Get" $ withServer $ \ host -> do + (Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice + + it "Servant.API.Delete" $ withServer $ \ host -> do + (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right () + + it "Servant.API.Capture" $ withServer $ \ host -> do + (Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0) + + it "Servant.API.ReqBody" $ withServer $ \ host -> do + let p = Person "Clara" 42 + (Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p + + it "Servant.API.QueryParam" $ withServer $ \ host -> do + Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice + Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host) + responseStatus `shouldBe` Status 400 "bob not found" + + it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do + (Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right [] + (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host)) + `shouldReturn` Right [Person "alice" 0, Person "bob" 1] + + context "Servant.API.QueryParam.QueryFlag" $ + forM_ [False, True] $ \ flag -> + it (show flag) $ withServer $ \ host -> do + (Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag + + it "Servant.API.MatrixParam" $ withServer $ \ host -> do + Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice + Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host) + responseStatus `shouldBe` Status 400 "bob not found" + + it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do + Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right [] + Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host) + `shouldReturn` Right [Person "alice" 0, Person "bob" 1] + + context "Servant.API.MatrixParam.MatrixFlag" $ + forM_ [False, True] $ \ flag -> + it (show flag) $ withServer $ \ host -> do + Arrow.left show <$> runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag + + it "Servant.API.Raw on success" $ withServer $ \ host -> do + res <- runEitherT (getRawSuccess methodGet host) + case res of + Left e -> assertFailure $ show e + Right (code, body, ct, response) -> do + (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") + C.responseBody response `shouldBe` body + C.responseStatus response `shouldBe` ok200 + + it "Servant.API.Raw on failure" $ withServer $ \ host -> do + res <- runEitherT (getRawFailure methodGet host) + case res of + Left e -> assertFailure $ show e + Right (code, body, ct, response) -> do + (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") + C.responseBody response `shouldBe` body + C.responseStatus response `shouldBe` badRequest400 + + modifyMaxSuccess (const 20) $ do + it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ + property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + ioProperty $ do + withServer $ \ host -> do + result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host) + return $ + result === Right (cap, num, flag, body) + + + context "client correctly handles error status codes" $ do + let test :: (WrappedApi, String) -> Spec + test (WrappedApi api, desc) = + it desc $ + withWaiDaemon (return (serve api (left (500, "error message")))) $ + \ host -> do + let getResponse :: BaseUrl -> EitherT ServantError IO () + getResponse = client api + Left FailureResponse{..} <- runEitherT (getResponse host) + responseStatus `shouldBe` (Status 500 "error message") + mapM_ test $ + (WrappedApi (Proxy :: Proxy Delete), "Delete") : + (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : + (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : + (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : + [] + + context "client returns errors appropriately" $ do + it "reports FailureResponse" $ withFailServer $ \ host -> do + Left res <- runEitherT (getDelete host) + case res of + FailureResponse (Status 404 "Not Found") _ _ -> return () + _ -> fail $ "expected 404 response, but got " <> show res + + it "reports DecodeFailure" $ withFailServer $ \ host -> do + Left res <- runEitherT (getCapture "foo" host) + case res of + DecodeFailure _ ("application/json") _ -> return () + _ -> fail $ "expected DecodeFailure, but got " <> show res + + it "reports ConnectionError" $ do + Right host <- return $ parseBaseUrl "127.0.0.1:987654" + Left res <- runEitherT (getGet host) + case res of + ConnectionError (C.FailedConnectionException2 "127.0.0.1" 987654 False _) -> return () + _ -> fail $ "expected ConnectionError, but got " <> show res + + it "reports UnsupportedContentType" $ withFailServer $ \ host -> do + Left res <- runEitherT (getGet host) + case res of + UnsupportedContentType ("application/octet-stream") _ -> return () + _ -> fail $ "expected UnsupportedContentType, but got " <> show res + + it "reports InvalidContentTypeHeader" $ withFailServer $ \ host -> do + Left res <- runEitherT (getBody alice host) + case res of + InvalidContentTypeHeader "fooooo" _ -> return () + _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res + +data WrappedApi where + WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a, + HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) => + Proxy api -> WrappedApi + + +-- * utils + +withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a +withWaiDaemon mkApplication action = do + application <- mkApplication + bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl) + where + acquire application = do + (notifyStart, waitForStart) <- lvar + (notifyKilled, waitForKilled) <- lvar + thread <- forkIO $ (do + (krakenPort, socket) <- openTestSocket + let settings = + setPort krakenPort $ -- set here just for consistency, shouldn't be + -- used (it's set in the socket) + setBeforeMainLoop (notifyStart krakenPort) + defaultSettings + runSettingsSocket settings socket application) + `finally` notifyKilled () + krakenPort <- waitForStart + let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort} + return (thread, waitForKilled, baseUrl) + free (thread, waitForKilled, _) = do + killThread thread + waitForKilled + + lvar :: IO (a -> IO (), IO a) + lvar = do + mvar <- newEmptyMVar + let put = putMVar mvar + wait = readMVar mvar + return (put, wait) + +openTestSocket :: IO (Port, Socket) +openTestSocket = do + s <- socket AF_INET Stream defaultProtocol + localhost <- inet_addr "127.0.0.1" + bind s (SockAddrInet aNY_PORT localhost) + listen s 1 + port <- socketPort s + return (fromIntegral port, s) + +pathGen :: Gen (NonEmptyList Char) +pathGen = fmap NonEmpty path + where + path = listOf1 $ elements $ + filter (not . (`elem` "?%[]/#;")) $ + filter isPrint $ + map chr [0..127] diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client/test/Servant/Common/BaseUrlSpec.hs new file mode 100644 index 00000000..5eef61dc --- /dev/null +++ b/servant-client/test/Servant/Common/BaseUrlSpec.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Common.BaseUrlSpec where + +import Control.Applicative +import Control.DeepSeq +import Test.Hspec +import Test.QuickCheck + +import Servant.Common.BaseUrl + +spec :: Spec +spec = do + describe "showBaseUrl" $ do + it "shows a BaseUrl" $ do + showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com" + + it "shows a https BaseUrl" $ do + showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com" + + describe "httpBaseUrl" $ do + it "allows to construct default http BaseUrls" $ do + BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80 + + describe "parseBaseUrl" $ do + it "is total" $ do + property $ \ string -> + deepseq (fmap show (parseBaseUrl string)) True + + it "is the inverse of showBaseUrl" $ do + property $ \ baseUrl -> + counterexample (showBaseUrl baseUrl) $ + parseBaseUrl (showBaseUrl baseUrl) === + Right baseUrl + + it "allows trailing slashes" $ do + parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80) + + context "urls without scheme" $ do + it "assumes http" $ do + parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80) + + it "allows port numbers" $ do + parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080) + + it "rejects ftp urls" $ do + parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft + +instance Arbitrary BaseUrl where + arbitrary = BaseUrl <$> + elements [Http, Https] <*> + hostNameGen <*> + portGen + where + -- this does not perfectly mirror the url standard, but I hope it's good + -- enough. + hostNameGen = do + let letters = ['a' .. 'z'] ++ ['A' .. 'Z'] + first <- elements letters + middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-']) + last <- elements letters + return (first : middle ++ [last]) + portGen = frequency $ + (1, return 80) : + (1, return 443) : + (1, choose (1, 20000)) : + [] + +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False) diff --git a/servant-client/test/Spec.hs b/servant-client/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-client/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}