packages feed

servant-haxl-client (empty) → 0.1.0.0

raw patch · 9 files changed

+1509/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, async, attoparsec, base, bytestring, deepseq, either, exceptions, hashable, haxl, hspec, http-client, http-client-tls, http-media, http-types, network, network-uri, safe, servant, servant-haxl-client, servant-server, string-conversions, text, transformers, wai, warp

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-haxl-client.cabal view
@@ -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 <http://hackage.haskell.org/package/servant servant> webservice.+  .+  See <http://haskell-servant.github.io/tutorial/client.html the client section of the tutorial>.+  .+  <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>+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
+ src/Servant/Client/Haxl.hs view
@@ -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)
+ src/Servant/Common/BaseUrl/Haxl.hs view
@@ -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
+ src/Servant/Common/Req/Haxl.hs view
@@ -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 ()
+ test/Servant/ClientSpec.hs view
@@ -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]
+ test/Servant/Common/BaseUrlSpec.hs view
@@ -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)
+ test/Spec.hs view
@@ -0,0 +1,6 @@+import           Servant.ClientSpec (failSpec, spec)++main :: IO ()+main = do+  spec+  failSpec