diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-haxl-client.cabal b/servant-haxl-client.cabal new file mode 100644 --- /dev/null +++ b/servant-haxl-client.cabal @@ -0,0 +1,85 @@ +name: servant-haxl-client +version: 0.1.0.0 +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. + . + See . + . + +license: BSD3 +license-file: LICENSE +author: ElvishJerricco, Alp Mestanogullari, Sönke Hahn, Julian K. Arni +maintainer: elvishjerricco@gmail.com +copyright: 2016 ElvishJerricco +category: Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.10 +homepage: http://github.com/ElvishJerricco/servant-haxl-client/ +Bug-reports: http://github.com/ElvishJerricco/servant-haxl-client/issues +source-repository head + type: git + location: http://github.com/ElvishJerricco/servant-haxl-client.git + +library + exposed-modules: + Servant.Client.Haxl + Servant.Common.BaseUrl.Haxl + Servant.Common.Req.Haxl + build-depends: + base >=4.8 && <5 + , aeson + , async + , attoparsec + , bytestring + , either + , exceptions + , hashable + , haxl + , http-client + , http-client-tls + , http-media + , http-types + , network-uri >= 2.6 + , safe + , servant == 0.4.* + , 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 + other-modules: + Servant.ClientSpec + , Servant.Common.BaseUrlSpec + build-depends: + base == 4.* + , aeson + , bytestring + , deepseq + , either + , haxl + , hspec == 2.* + , http-client + , http-client-tls + , http-media + , http-types + , HUnit + , network >= 2.6 + , QuickCheck >= 2.7 + , servant == 0.4.* + , servant-haxl-client + , servant-server == 0.4.* + , text + , wai + , warp diff --git a/src/Servant/Client/Haxl.hs b/src/Servant/Client/Haxl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Haxl.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | This module provides 'client' which can automatically generate +-- querying functions for each endpoint just from the type representing your +-- API. +module Servant.Client.Haxl + ( client + , initServantClientState + , HasClient(..) + , ServantError(..) + , module Servant.Common.BaseUrl.Haxl + ) where + +import Control.Monad +import Data.ByteString.Lazy (ByteString) +import Data.List +import Data.Proxy +import Data.String.Conversions +import Data.Text (unpack) +import GHC.TypeLits +import Haxl.Core (GenHaxl, State) +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client.TLS +import Network.HTTP.Media +import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types.Header as HTTP +import Servant.API +import Servant.Common.BaseUrl.Haxl +import Servant.Common.Req.Haxl + +-- * Accessing APIs as a Client + +-- | 'client' allows you to produce operations to query an API from a client. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: EitherT String IO [Book] +-- > postNewBook :: Book -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout +client p = clientWithRoute p defReq + +initServantClientState :: Int -> IO (State ServantRequest) +initServantClientState numThreads = + ServantRequestState numThreads <$> newManager tlsManagerSettings + +-- | 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 -> BaseUrl -> Client layout + +{-type Client layout = Client 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 '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: EitherT String IO [Book] +-- > postNewBook :: Book -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +instance (HasClient a, HasClient b) => HasClient (a :<|> b) where + type Client (a :<|> b) = Client a :<|> Client b + clientWithRoute Proxy req baseurl = + clientWithRoute (Proxy :: Proxy a) req baseurl :<|> + clientWithRoute (Proxy :: Proxy b) req baseurl + +-- | 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 '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> EitherT String IO Book +-- > getBook = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl val = + clientWithRoute (Proxy :: Proxy sublayout) + (appendToPath p req) + baseurl + + 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 {-# OVERLAPPABLE #-} + -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances + (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where + type Client (Delete cts' a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req (SelectCodes [200, 202]) baseurl + +-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Delete cts ()) where + type Client (Delete cts ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodDelete req (SelectCodes [204]) baseurl + +-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances + ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) + ) => HasClient (Delete cts' (Headers ls a)) where + type Client (Delete cts' (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req (SelectCodes [200, 202]) baseurl + return Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + +-- | 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 {-# OVERLAPPABLE #-} + (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where + type Client (Get (ct ': cts) result) = GenHaxl () result + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req (SelectCodes [200, 203]) baseurl + +-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content +-- HTTP status. +instance {-# OVERLAPPING #-} + HasClient (Get (ct ': cts) ()) where + type Client (Get (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req = + performRequestNoBody H.methodGet req (SelectCodes [204]) + +-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Get (ct ': cts) (Headers ls a)) where + type Client (Get (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req (SelectCodes [200, 203, 204]) baseurl + return Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + +-- | 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 { referrer :: Text } +-- > deriving (Eq, Show, Generic, FromText, ToText) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> EitherT String IO Book +-- > viewReferer = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or e.g 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 baseurl mval = + clientWithRoute (Proxy :: Proxy sublayout) + (maybe req + (\value -> Servant.Common.Req.Haxl.addHeader hname value req) + mval + ) + baseurl + + 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 {-# OVERLAPPABLE #-} + (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where + type Client (Post (ct ': cts) a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req (SelectCodes [200, 201, 202]) baseurl + +-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Post (ct ': cts) ()) where + type Client (Post (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodPost req (SelectCodes [204]) baseurl + +-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Post (ct ': cts) (Headers ls a)) where + type Client (Post (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req (SelectCodes [200, 201, 202]) baseurl + return Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + +-- | 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 {-# OVERLAPPABLE #-} + (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where + type Client (Put (ct ': cts) a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req (SelectCodes [200,201]) baseurl + +-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Put (ct ': cts) ()) where + type Client (Put (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodPut req (SelectCodes [204]) baseurl + +-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Put (ct ': cts) (Headers ls a)) where + type Client (Put (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req (SelectCodes [200, 201]) baseurl + return Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + +-- | 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 {-# OVERLAPPABLE #-} + (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where + type Client (Patch (ct ': cts) a) = GenHaxl () a + clientWithRoute Proxy req baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req (SelectCodes [200,201]) baseurl + +-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content +-- HTTP header. +instance {-# OVERLAPPING #-} + HasClient (Patch (ct ': cts) ()) where + type Client (Patch (ct ': cts) ()) = GenHaxl () () + clientWithRoute Proxy req baseurl = + void $ performRequestNoBody H.methodPatch req (SelectCodes [204]) baseurl + +-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the +-- corresponding headers. +instance {-# OVERLAPPING #-} + ( MimeUnrender ct a, BuildHeadersTo ls + ) => HasClient (Patch (ct ': cts) (Headers ls a)) where + type Client (Patch (ct ': cts) (Headers ls a)) = GenHaxl () (Headers ls a) + clientWithRoute Proxy req baseurl = do + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req (SelectCodes [200, 201, 204]) baseurl + return Headers { getResponse = resp + , getHeadersHList = buildHeadersTo hdrs + } + +-- | 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 '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl mparam = + clientWithRoute (Proxy :: Proxy sublayout) + (maybe req + (flip (appendToQueryString pname) req . Just) + mparamText + ) + baseurl + + 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 '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl paramlist = + clientWithRoute (Proxy :: Proxy sublayout) + (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) + req + paramlist' + ) + baseurl + + 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 '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> EitherT String IO [Book] +-- > getBooks = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl flag = + clientWithRoute (Proxy :: Proxy sublayout) + (if flag + then appendToQueryString paramname Nothing req + else req + ) + baseurl + + 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 '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl mparam = + clientWithRoute (Proxy :: Proxy sublayout) + (maybe req + (flip (appendToMatrixParams pname . Just) req) + mparamText + ) + baseurl + + 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 '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> EitherT String IO [Book] +-- > getBooksBy = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl paramlist = + clientWithRoute (Proxy :: Proxy sublayout) + (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) + req + paramlist' + ) + baseurl + + 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 '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> EitherT String IO [Book] +-- > getBooks = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl flag = + clientWithRoute (Proxy :: Proxy sublayout) + (if flag + then appendToMatrixParams paramname Nothing req + else req + ) + baseurl + + 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 -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + + clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw + clientWithRoute Proxy req baseurl httpMethod = performRequest httpMethod req AllCodes baseurl + +-- | 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 '[JSON] Book :> Post '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > addBook :: Book -> EitherT String IO Book +-- > addBook = client myApi host +-- > where host = BaseUrl Http "localhost" 8080 +-- > -- 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 baseurl body = + clientWithRoute (Proxy :: Proxy sublayout) + (let ctProxy = Proxy :: Proxy ct + in setRQBody (mimeRender ctProxy body) + (contentType ctProxy) + req + ) + baseurl + +-- | 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/src/Servant/Common/BaseUrl/Haxl.hs b/src/Servant/Common/BaseUrl/Haxl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Common/BaseUrl/Haxl.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} +module Servant.Common.BaseUrl.Haxl where + +import Data.Hashable +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) + +instance Hashable Scheme where + hashWithSalt s Http = hashWithSalt s (0 :: Int) + hashWithSalt s Https = hashWithSalt s (1 :: Int) + +-- | 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) + +instance Hashable BaseUrl where + hashWithSalt s (BaseUrl sc h p) = hashWithSalt s (sc, h, p) + +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/src/Servant/Common/Req/Haxl.hs b/src/Servant/Common/Req/Haxl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Common/Req/Haxl.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Common.Req.Haxl where + +import Control.Concurrent.Async +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.ByteString.Lazy hiding (elem, filter, map, null, + pack) +import Data.Hashable +import Data.Proxy +import Data.String +import Data.String.Conversions +import Data.Text (Text) +import Data.Text.Encoding +import GHC.Generics +import Haxl.Core hiding (Request, catch) +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Media +import Network.HTTP.Types +import qualified Network.HTTP.Types.Header as HTTP +import Network.URI +import Servant.API.ContentTypes +import Servant.Common.BaseUrl.Haxl +import Servant.Common.Text + +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) + +instance Exception ServantError where + +data Req = Req + { reqPath :: String + , qs :: QueryText + , reqBody :: Maybe (ByteString, MediaType) + , reqAccept :: [MediaType] + , headers :: [(String, Text)] + } deriving (Show, Eq, Ord, Generic) + +instance Hashable Req where + hashWithSalt s (Req p q b a h) = hashWithSalt s (p, q, bHash, aHash, h) + where + hashMediaType m = hashWithSalt s (show m) + bHash = fmap (fmap hashMediaType) b + aHash = fmap hashMediaType a + +data WantedStatusCodes = AllCodes | SelectCodes [Int] + deriving (Show, Eq, Ord, Generic) + +instance Hashable WantedStatusCodes where + hashWithSalt s AllCodes = hashWithSalt s (0::Int) + hashWithSalt s (SelectCodes codes) = hashWithSalt s (1::Int, codes) + +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 :: MonadThrow m => Req -> BaseUrl -> m Request +reqToRequest req (BaseUrl reqScheme reqHost reqPort) = + (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 + +displayHttpRequest :: Method -> String +displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" + + +performRequest_ :: Manager -> Method -> Req -> WantedStatusCodes -> BaseUrl + -> EitherT ServantError IO ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest_ manager reqMethod req wantedStatus reqHost = do + partialRequest <- liftIO $ reqToRequest req reqHost + + let request = partialRequest { Client.method = reqMethod + , checkStatus = \ _status _headers _cookies -> Nothing + } + + eResponse <- liftIO $ 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 + hrds = Client.responseHeaders 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 (wantedStatus `wants` status_code) $ + left $ FailureResponse status ct body + return (status_code, body, ct, hrds, response) + where + wants AllCodes _ = True + wants (SelectCodes codes) status_code = status_code `elem` codes + +catchHttpException :: IO a -> IO (Either HttpException a) +catchHttpException action = + catch (Right <$> action) (pure . Left) + +data ServantRequest a where + ServantRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> + ServantRequest (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + +deriving instance Show (ServantRequest a) +deriving instance Eq (ServantRequest a) + +instance Show1 ServantRequest where + show1 = show + +instance Hashable (ServantRequest a) where + hashWithSalt s (ServantRequest m r w h) = hashWithSalt s (m, r, w, h) + +instance StateKey ServantRequest where + data State ServantRequest = ServantRequestState Int Manager + +instance DataSourceName ServantRequest where + dataSourceName _ = "ServantRequest" + +instance DataSource () ServantRequest where + fetch (ServantRequestState numThreads manager) _ () requests = AsyncFetch $ \inner -> do + sem <- newQSem numThreads + asyncs <- mapM (handler sem) requests + inner + mapM_ wait asyncs + where + handler :: QSem -> BlockedFetch ServantRequest -> IO (Async ()) + handler sem (BlockedFetch ((ServantRequest met req wantedStatus reqHost) :: ServantRequest a) rvar) = + async $ bracket_ (waitQSem sem) (signalQSem sem) $ do + e <- runEitherT $ performRequest_ manager met req wantedStatus reqHost + case e of + Left err -> putFailure rvar err + Right a -> putSuccess rvar a + return () + +performRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) +performRequest m r w h = dataFetch $ ServantRequest m r w h + +performRequestCT :: MimeUnrender ct result => + Proxy ct -> Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () ([HTTP.Header], result) +performRequestCT ct reqMethod req wantedStatus reqHost = do + let acceptCT = contentType ct + (_status, respBody, respCT, hrds, _response) <- + performRequest reqMethod (req { reqAccept = [acceptCT] }) wantedStatus reqHost + unless (matches respCT acceptCT) $ throwM $ UnsupportedContentType respCT respBody + case mimeUnrender ct respBody of + Left err -> throwM $ DecodeFailure err respCT respBody + Right val -> return (hrds, val) + +performRequestNoBody :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () () +performRequestNoBody reqMethod req wantedStatus reqHost = do + _ <- performRequest reqMethod req wantedStatus reqHost + return () diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/ClientSpec.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fcontext-stack=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.ClientSpec where + +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 Haxl.Core hiding (try) +import qualified Network.HTTP.Client as C +import Network.HTTP.Media +import Network.HTTP.Types hiding (Header) +import qualified Network.HTTP.Types as HTTP +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.Haxl +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 TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] + +type Api = + "get" :> Get '[JSON] Person + :<|> "deleteEmpty" :> 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])]) + :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) + :<|> "deleteContentType" :> Delete '[JSON] () +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 $ ServantErr 400 (name ++ " not found") "" [] + Nothing -> left $ ServantErr 400 "missing parameter" "" []) + :<|> (\ names -> return (zipWith Person names [0..])) + :<|> return + :<|> (\ name -> case name of + Just "alice" -> return alice + Just name -> left $ ServantErr 400 (name ++ " not found") "" [] + Nothing -> left $ ServantErr 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)) + :<|> (return $ addHeader 1729 $ addHeader "eg2" True) + :<|> return () + ) + +withServer :: (BaseUrl -> IO a) -> IO a +withServer action = withWaiDaemon (return server) action + +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 + +testHaxl :: GenHaxl () a -> IO (Either ServantError a) +testHaxl haxl = do + env <- getEnv + try $ runHaxl env haxl + where + getEnv :: IO (Env ()) + getEnv = do + state <- initServantClientState 4 + initEnv (stateSet state stateEmpty) () + +spec :: IO () +spec = withServer $ \ baseUrl -> do + let getGet :: GenHaxl () Person + getDeleteEmpty :: GenHaxl () () + getCapture :: String -> GenHaxl () Person + getBody :: Person -> GenHaxl () Person + getQueryParam :: Maybe String -> GenHaxl () Person + getQueryParams :: [String] -> GenHaxl () [Person] + getQueryFlag :: Bool -> GenHaxl () Bool + getMatrixParam :: Maybe String -> GenHaxl () Person + getMatrixParams :: [String] -> GenHaxl () [Person] + getMatrixFlag :: Bool -> GenHaxl () Bool + getRawSuccess :: Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) + getRawFailure :: Method -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString) + getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> GenHaxl () (String, Maybe Int, Bool, [(String, [Rational])]) + getRespHeaders :: GenHaxl () (Headers TestHeaders Bool) + getDeleteContentType :: GenHaxl () () + ( getGet + :<|> getDeleteEmpty + :<|> getCapture + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getMatrixParam + :<|> getMatrixParams + :<|> getMatrixFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple + :<|> getRespHeaders + :<|> getDeleteContentType) + = client api baseUrl + + hspec $ do + it "Servant.API.Get" $ do + (Arrow.left show <$> testHaxl getGet) `shouldReturn` Right alice + + describe "Servant.API.Delete" $ do + it "allows empty content type" $ do + (Arrow.left show <$> testHaxl getDeleteEmpty) `shouldReturn` Right () + + it "allows content type" $ do + (Arrow.left show <$> testHaxl getDeleteContentType) `shouldReturn` Right () + + it "Servant.API.Capture" $ do + (Arrow.left show <$> testHaxl (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0) + + it "Servant.API.ReqBody" $ do + let p = Person "Clara" 42 + (Arrow.left show <$> testHaxl (getBody p)) `shouldReturn` Right p + + it "Servant.API.QueryParam" $ do + Arrow.left show <$> testHaxl (getQueryParam (Just "alice")) `shouldReturn` Right alice + Left FailureResponse{..} <- testHaxl (getQueryParam (Just "bob")) + responseStatus `shouldBe` Status 400 "bob not found" + + it "Servant.API.QueryParam.QueryParams" $ do + (Arrow.left show <$> testHaxl (getQueryParams [])) `shouldReturn` Right [] + (Arrow.left show <$> testHaxl (getQueryParams ["alice", "bob"])) + `shouldReturn` Right [Person "alice" 0, Person "bob" 1] + + context "Servant.API.QueryParam.QueryFlag" $ + forM_ [False, True] $ \ flag -> + it (show flag) $ do + (Arrow.left show <$> testHaxl (getQueryFlag flag)) `shouldReturn` Right flag + + it "Servant.API.MatrixParam" $ do + Arrow.left show <$> testHaxl (getMatrixParam (Just "alice")) `shouldReturn` Right alice + Left FailureResponse{..} <- testHaxl (getMatrixParam (Just "bob")) + responseStatus `shouldBe` Status 400 "bob not found" + + it "Servant.API.MatrixParam.MatrixParams" $ do + Arrow.left show <$> testHaxl (getMatrixParams []) `shouldReturn` Right [] + Arrow.left show <$> testHaxl (getMatrixParams ["alice", "bob"]) + `shouldReturn` Right [Person "alice" 0, Person "bob" 1] + + context "Servant.API.MatrixParam.MatrixFlag" $ + forM_ [False, True] $ \ flag -> + it (show flag) $ do + Arrow.left show <$> testHaxl (getMatrixFlag flag) `shouldReturn` Right flag + + it "Servant.API.Raw on success" $ do + res <- testHaxl (getRawSuccess methodGet) + 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" $ do + res <- testHaxl (getRawFailure methodGet) + 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 + + it "Returns headers appropriately" $ withServer $ \ _ -> do + res <- testHaxl getRespHeaders + case res of + Left e -> assertFailure $ show e + Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + + 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 + result <- Arrow.left show <$> testHaxl (getMultiple cap num flag body) + 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 $ ServantErr 500 "error message" "" []))) $ + \ host -> do + let getResponse :: GenHaxl () () + getResponse = client api host + Left FailureResponse{..} <- testHaxl getResponse + responseStatus `shouldBe` (Status 500 "error message") + mapM_ test $ + (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : + (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : + (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : + (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : + [] + +failSpec :: IO () +failSpec = withFailServer $ \ baseUrl -> do + let getGet :: GenHaxl () Person + getDeleteEmpty :: GenHaxl () () + getCapture :: String -> GenHaxl () Person + getBody :: Person -> GenHaxl () Person + ( getGet + :<|> getDeleteEmpty + :<|> getCapture + :<|> getBody + :<|> _ ) + = client api baseUrl + getGetWrongHost :: GenHaxl () Person + (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872) + + hspec $ do + context "client returns errors appropriately" $ do + it "reports FailureResponse" $ do + Left res <- testHaxl getDeleteEmpty + case res of + FailureResponse (Status 404 "Not Found") _ _ -> return () + _ -> fail $ "expected 404 response, but got " <> show res + + it "reports DecodeFailure" $ do + Left res <- testHaxl (getCapture "foo") + case res of + DecodeFailure _ ("application/json") _ -> return () + _ -> fail $ "expected DecodeFailure, but got " <> show res + + it "reports ConnectionError" $ do + Left res <- testHaxl getGetWrongHost + case res of + ConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _) -> return () + _ -> fail $ "expected ConnectionError, but got " <> show res + + it "reports UnsupportedContentType" $ do + Left res <- testHaxl getGet + case res of + UnsupportedContentType ("application/octet-stream") _ -> return () + _ -> fail $ "expected UnsupportedContentType, but got " <> show res + + it "reports InvalidContentTypeHeader" $ do + Left res <- testHaxl (getBody alice) + case res of + InvalidContentTypeHeader "fooooo" _ -> return () + _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res + +data WrappedApi where + WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a, + HasClient api, Client api ~ GenHaxl () ()) => + 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` ("?%[]/#;" :: String))) $ + filter isPrint $ + map chr [0..127] diff --git a/test/Servant/Common/BaseUrlSpec.hs b/test/Servant/Common/BaseUrlSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Common/BaseUrlSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Common.BaseUrlSpec where + +import Control.DeepSeq +import Test.Hspec +import Test.QuickCheck + +import Servant.Common.BaseUrl.Haxl + +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/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,6 @@ +import Servant.ClientSpec (failSpec, spec) + +main :: IO () +main = do + spec + failSpec