packages feed

servant-client-core (empty) → 0.12

raw patch · 17 files changed

+1319/−0 lines, 17 filesdep +QuickCheckdep +basedep +base-compatsetup-changed

Dependencies added: QuickCheck, base, base-compat, base64-bytestring, bytestring, containers, deepseq, exceptions, generics-sop, hspec, http-api-data, http-media, http-types, mtl, network-uri, safe, semigroups, servant, servant-client-core, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,8 @@+[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)++0.12+----++- First version. Factored out of `servant-client` all the functionality that was+  independent of the `http-client` backend.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Servant Contributors++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Servant Contributors 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.
+ README.md view
@@ -0,0 +1,30 @@+# servant-client-core++![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)++HTTP-client-agnostic client functions for servant APIs.++This library should mainly be of interest to backend- and combinator-writers.++## For backend-writers++If you are creating a new backend, you'll need to:++1. Define a `RunClient` instance for your datatype (call it `MyMonad`)+2. Define a `ClientLike` instance. This will look like:++``` haskell+instance ClientLike (MyMonad a) (MyMonad a) where+  mkClient = id+```++3. Re-export the module Servant.Client.Core.Reexport so that your end-users+   can be blissfully unaware of 'servant-client-core', and so each+   backend-package comes closer to the warm hearth of the drop-in-replacement+   equivalence class.++## For combinator-writers++You'll need to define a new `HasClient` instance for your combinator. There are+plenty of examples to guide you in the+[HasClient](src/Servant/Client/Core/Internal/HasClient.hs) module.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ include/overlapping-compat.h view
@@ -0,0 +1,8 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_  {-# OVERLAPPING #-}+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#endif
+ servant-client-core.cabal view
@@ -0,0 +1,82 @@+name:                servant-client-core+version:             0.12+synopsis:            Core functionality and class for client function generation for servant APIs+description:+  This library provides backend-agnostic generation of client functions. For+  more information, see the README.+license:             BSD3+license-file:        LICENSE+author:              Servant Contributors+maintainer:          haskell-servant-maintainers@googlegroups.com+homepage:            http://haskell-servant.readthedocs.org/+bug-reports:         http://github.com/haskell-servant/servant/issues+cabal-version:       >=1.10+copyright:           2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors+category:            Web+build-type:          Simple+extra-source-files:+  include/*.h+  CHANGELOG.md+  README.md+tested-with:+  GHC==7.8.4+  GHC==7.10.3+  GHC==8.0.2+  GHC==8.2.1++source-repository head+  type:              git+  location:          http://github.com/haskell-servant/servant.git++library+  exposed-modules:+      Servant.Client.Core+      Servant.Client.Core.Reexport+      Servant.Client.Core.Internal.Auth+      Servant.Client.Core.Internal.BaseUrl+      Servant.Client.Core.Internal.BasicAuth+      Servant.Client.Core.Internal.Generic+      Servant.Client.Core.Internal.HasClient+      Servant.Client.Core.Internal.Request+      Servant.Client.Core.Internal.RunClient+  build-depends:+      base                  >= 4.7      && < 4.11+    , base-compat           >= 0.9.1    && < 0.10+    , base64-bytestring     >= 1.0.0.1  && < 1.1+    , bytestring            >= 0.10     && < 0.11+    , containers            >= 0.5      && < 0.6+    , exceptions            >= 0.8      && < 0.9+    , generics-sop          >= 0.1.0.0  && < 0.4+    , http-api-data         >= 0.3.6    && < 0.4+    , http-media            >= 0.6.2    && < 0.8+    , http-types            >= 0.8.6    && < 0.11+    , mtl                   >= 2.1      && < 2.3+    , network-uri           >= 2.6      && < 2.7+    , safe                  >= 0.3.9    && < 0.4+    , servant               == 0.12.*+    , text                  >= 1.2      && < 1.3+  if !impl(ghc >= 8.0)+    build-depends:+        semigroups          >=0.16.2.2 && <0.19+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall+  include-dirs:        include++test-suite spec+  type:                exitcode-stdio-1.0+  ghc-options:         -Wall+  default-language:    Haskell2010+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:+      base+    , base-compat+    , deepseq+    , servant-client-core+    , hspec == 2.*+    , QuickCheck >= 2.7 && < 2.11+  build-tool-depends:+    hspec-discover:hspec-discover+  other-modules:+      Servant.Client.Core.Internal.BaseUrlSpec
+ src/Servant/Client/Core.hs view
@@ -0,0 +1,65 @@+-- | This module provides backend-agnostic functionality for generating clients+-- from @servant@ APIs. By "backend," we mean something that concretely+-- executes the request, such as:+--+--  * The @http-client@ library+--  * The @haxl@ library+--  * GHCJS via FFI+--+-- etc.+--+-- Each backend is encapsulated in a monad that is an instance of the+-- 'RunClient' class.+--+-- This library is primarily of interest to backend-writers and+-- combinator-writers. For more information, see the README.md+module Servant.Client.Core+  (+  -- * Client generation+    clientIn+  , HasClient(..)++  -- * Request+  , Request+  , RequestF(..)+  , defaultRequest+  , RequestBody(..)++  -- * Authentication+  , mkAuthenticatedRequest+  , basicAuthReq+  , AuthenticatedRequest(..)+  , AuthClientData++  -- * Generic Client+  , ClientLike(..)+  , genericMkClientL+  , genericMkClientP+  , ServantError(..)+  , EmptyClient(..)+++  -- * Response+  , Response(..)+  , RunClient(..)+  , module Servant.Client.Core.Internal.BaseUrl++  -- * Writing HasClient instances+  -- | These functions need not be re-exported by backend libraries.+  , addHeader+  , appendToQueryString+  , appendToPath+  , setRequestBodyLBS+  , setRequestBody+  ) where+import           Servant.Client.Core.Internal.Auth+import           Servant.Client.Core.Internal.BaseUrl   (BaseUrl (..),+                                                         InvalidBaseUrlException,+                                                         Scheme (..),+                                                         parseBaseUrl,+                                                         showBaseUrl)+import           Servant.Client.Core.Internal.BasicAuth+import           Servant.Client.Core.Internal.HasClient+import           Servant.Client.Core.Internal.Generic+import           Servant.Client.Core.Internal.Request+import           Servant.Client.Core.Internal.RunClient
+ src/Servant/Client/Core/Internal/Auth.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Authentication for clients++module Servant.Client.Core.Internal.Auth where++import           Servant.Client.Core.Internal.Request (Request)++-- | For a resource protected by authentication (e.g. AuthProtect), we need+-- to provide the client with some data used to add authentication data+-- to a request+--+-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE+type family AuthClientData a :: *++-- | For better type inference and to avoid usage of a data family, we newtype+-- wrap the combination of some 'AuthClientData' and a function to add authentication+-- data to a request+--+-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE+newtype AuthenticatedRequest a =+  AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) }++-- | Handy helper to avoid wrapping datatypes in tuples everywhere.+--+-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE+mkAuthenticatedRequest :: AuthClientData a+                  -> (AuthClientData a -> Request -> Request)+                  -> AuthenticatedRequest a+mkAuthenticatedRequest val func = AuthenticatedRequest (val, func)
+ src/Servant/Client/Core/Internal/BaseUrl.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE ViewPatterns       #-}+module Servant.Client.Core.Internal.BaseUrl where++import           Control.Monad.Catch (Exception, MonadThrow, throwM)+import           Data.List+import           Data.Typeable+import           GHC.Generics+import           Network.URI         hiding (path)+import           Safe+import           Text.Read++-- | URI scheme to use+data Scheme =+    Http  -- ^ http://+  | Https -- ^ https://+  deriving (Show, Eq, Ord, Generic)++-- | Simple data type to represent the target of HTTP requests+--   for servant's automatically-generated clients.+data BaseUrl = BaseUrl+  { baseUrlScheme :: Scheme -- ^ URI scheme to use+  , baseUrlHost   :: String   -- ^ host (eg "haskell.org")+  , baseUrlPort   :: Int      -- ^ port (eg 80)+  , baseUrlPath   :: String   -- ^ path (eg "/a/b/c")+  } deriving (Show, Ord, Generic)++instance Eq BaseUrl where+    BaseUrl a b c path == BaseUrl a' b' c' path'+        = a == a' && b == b' && c == c' && s path == s path'+        where s ('/':x) = x+              s x       = x++showBaseUrl :: BaseUrl -> String+showBaseUrl (BaseUrl urlscheme host port path) =+  schemeString ++ "//" ++ host ++ (portString </> path)+    where+      a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b+      schemeString = case urlscheme of+        Http  -> "http:"+        Https -> "https:"+      portString = case (urlscheme, port) of+        (Http, 80) -> ""+        (Https, 443) -> ""+        _ -> ":" ++ show port++data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)+instance Exception InvalidBaseUrlException++parseBaseUrl :: MonadThrow m => String -> m 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)))) path "" "") ->+    return (BaseUrl Http host port path)+  Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->+    return (BaseUrl Http host 80 path)+  Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->+    return (BaseUrl Https host port path)+  Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->+    return (BaseUrl Https host 443 path)+  _ -> if "://" `isInfixOf` s+    then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)+    else parseBaseUrl ("http://" ++ s)+ where+  removeTrailingSlash str = case lastMay str of+    Just '/' -> init str+    _ -> str
+ src/Servant/Client/Core/Internal/BasicAuth.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Basic Authentication for clients++module Servant.Client.Core.Internal.BasicAuth where++import           Data.ByteString.Base64               (encode)+import           Data.Monoid                          ((<>))+import           Data.Text.Encoding                   (decodeUtf8)+import           Servant.API.BasicAuth                (BasicAuthData (BasicAuthData))+import           Servant.Client.Core.Internal.Request (Request, addHeader)++-- | Authenticate a request using Basic Authentication+basicAuthReq :: BasicAuthData -> Request -> Request+basicAuthReq (BasicAuthData user pass) req =+    let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))+    in addHeader "Authorization" authText req
+ src/Servant/Client/Core/Internal/Generic.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#include "overlapping-compat.h"++module Servant.Client.Core.Internal.Generic where++import Generics.SOP   (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)+import Servant.API    ((:<|>)(..))++-- | This class allows us to match client structure with client functions+-- produced with 'client' without explicit pattern-matching.+--+-- The client structure needs a 'Generics.SOP.Generic' instance.+--+-- Example:+--+-- > type API+-- >     = "foo" :> Capture "x" Int :> Get '[JSON] Int+-- >  :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]+-- >  :<|> Capture "nested" Int :> NestedAPI+-- >+-- > type NestedAPI+-- >     = Get '[JSON] String+-- >  :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()+-- >+-- > data APIClient = APIClient+-- >   { getFoo         :: Int -> ClientM Int+-- >   , postBar        :: Maybe Char -> Maybe String -> ClientM [Int]+-- >   , mkNestedClient :: Int -> NestedClient+-- >   } deriving GHC.Generic+-- >+-- > instance Generics.SOP.Generic APIClient+-- > instance (Client API ~ client) => ClientLike client APIClient+-- >+-- > data NestedClient = NestedClient+-- >  { getString :: ClientM String+-- >  , postBaz   :: Maybe Char -> ClientM ()+-- >  } deriving GHC.Generic+-- >+-- > instance Generics.SOP.Generic NestedClient+-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient+-- >+-- > mkAPIClient :: APIClient+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))+--+-- By default, left-nested alternatives are expanded:+--+-- > type API1+-- >     = "foo" :> Capture "x" Int :> Get '[JSON] Int+-- >  :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String+-- >+-- > type API2+-- >     = "baz" :> QueryParam "c" Char :> Post '[JSON] ()+-- >+-- > type API = API1 :<|> API2+-- >+-- > data APIClient = APIClient+-- >   { getFoo  :: Int -> ClientM Int+-- >   , postBar :: Maybe Char -> ClientM String+-- >   , postBaz :: Maybe Char -> ClientM ()+-- >   } deriving GHC.Generic+-- >+-- > instance Generics.SOP.Generic APIClient+-- > instance (Client API ~ client) => ClientLike client APIClient+-- >+-- > mkAPIClient :: APIClient+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))+--+-- If you want to define client for @API1@ as a separate data structure,+-- you can use 'genericMkClientP':+--+-- > data APIClient1 = APIClient1+-- >   { getFoo  :: Int -> ClientM Int+-- >   , postBar :: Maybe Char -> ClientM String+-- >   } deriving GHC.Generic+-- >+-- > instance Generics.SOP.Generic APIClient1+-- > instance (Client API1 ~ client) => ClientLike client APIClient1+-- >+-- > data APIClient = APIClient+-- >   { mkAPIClient1 :: APIClient1+-- >   , postBaz      :: Maybe Char -> ClientM ()+-- >   } deriving GHC.Generic+-- >+-- > instance Generics.SOP.Generic APIClient+-- > instance (Client API ~ client) => ClientLike client APIClient where+-- >   mkClient = genericMkClientP+-- >+-- > mkAPIClient :: APIClient+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))+class ClientLike client custom where+  mkClient :: client -> custom+  default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)+    => client -> custom+  mkClient = genericMkClientL++instance ClientLike client custom+      => ClientLike (a -> client) (a -> custom) where+  mkClient c = mkClient . c++-- | Match client structure with client functions, regarding left-nested API clients+-- as separate data structures.+class GClientLikeP client xs where+  gMkClientP :: client -> NP I xs++instance (GClientLikeP b (y ': xs), ClientLike a x)+      => GClientLikeP (a :<|> b) (x ': y ': xs) where+  gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b++instance ClientLike a x => GClientLikeP a '[x] where+  gMkClientP a = I (mkClient a) :* Nil++-- | Match client structure with client functions, expanding left-nested API clients+-- in the same structure.+class GClientLikeL (xs :: [*]) (ys :: [*]) where+  gMkClientL :: NP I xs -> NP I ys++instance GClientLikeL '[] '[] where+  gMkClientL Nil = Nil++instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where+  gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs++type family ClientList (client :: *) (acc :: [*]) :: [*] where+  ClientList (a :<|> b) acc = ClientList a (ClientList b acc)+  ClientList a acc = a ': acc++class GClientList client (acc :: [*]) where+  gClientList :: client -> NP I acc -> NP I (ClientList client acc)++instance (GClientList b acc, GClientList a (ClientList b acc))+  => GClientList (a :<|> b) acc where+  gClientList (a :<|> b) acc = gClientList a (gClientList b acc)++instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc))+  => GClientList client acc where+  gClientList c acc = I c :* acc++-- | Generate client structure from client type, expanding left-nested API (done by default).+genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)+  => client -> custom+genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil++-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.+genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)+  => client -> custom+genericMkClientP = to . SOP . Z . gMkClientP+
+ src/Servant/Client/Core/Internal/HasClient.hs view
@@ -0,0 +1,541 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++#include "overlapping-compat.h"+module Servant.Client.Core.Internal.HasClient where++import           Prelude                                ()+import           Prelude.Compat++import           Data.Foldable                          (toList)+import           Data.List                              (foldl')+import           Data.Proxy                             (Proxy (Proxy))+import           Data.Sequence                          (fromList)+import           Data.String                            (fromString)+import           Data.Text                              (pack)+import           GHC.TypeLits                           (KnownSymbol, symbolVal)+import qualified Network.HTTP.Types                     as H+import           Servant.API                            ((:<|>) ((:<|>)), (:>),+                                                         AuthProtect, BasicAuth,+                                                         BasicAuthData,+                                                         BuildHeadersTo (..),+                                                         Capture, CaptureAll,+                                                         Description, EmptyAPI,+                                                         Header, Headers (..),+                                                         HttpVersion, IsSecure,+                                                         MimeRender (mimeRender),+                                                         MimeUnrender (mimeUnrender),+                                                         NoContent (NoContent),+                                                         QueryFlag, QueryParam,+                                                         QueryParams, Raw,+                                                         ReflectMethod (..),+                                                         RemoteHost, ReqBody,+                                                         Summary, ToHttpApiData,+                                                         Vault, Verb,+                                                         WithNamedContext,+                                                         contentType,+                                                         getHeadersHList,+                                                         getResponse,+                                                         toQueryParam,+                                                         toUrlPiece)+import           Servant.API.ContentTypes               (contentTypes)++import           Servant.Client.Core.Internal.Auth+import           Servant.Client.Core.Internal.BasicAuth+import           Servant.Client.Core.Internal.Request+import           Servant.Client.Core.Internal.RunClient++-- * Accessing APIs as a Client++-- | 'clientIn' allows you to produce operations to query an API from a client+-- within a 'RunClient' monad.+--+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+-- >         :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > clientM :: Proxy ClientM+-- > clientM = Proxy+-- >+-- > getAllBooks :: ClientM [Book]+-- > postNewBook :: Book -> ClientM Book+-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM+clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api+clientIn p pm = clientWithRoute pm p defaultRequest+++-- | This class lets us define how each API combinator influences the creation+-- of an HTTP request.+--+-- Unless you are writing a new backend for @servant-client-core@ or new+-- combinators that you want to support client-generation, you can ignore this+-- class.+class RunClient m => HasClient m api where+  type Client (m :: * -> *) (api :: *) :: *+  clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api+++-- | 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 :: ClientM [Book]+-- > postNewBook :: Book -> ClientM Book+-- > (getAllBooks :<|> postNewBook) = client myApi+instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where+  type Client m (a :<|> b) = Client m a :<|> Client m b+  clientWithRoute pm Proxy req =+    clientWithRoute pm (Proxy :: Proxy a) req :<|>+    clientWithRoute pm (Proxy :: Proxy b) req++-- | Singleton type representing a client for an empty API.+data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)++-- | The client for 'EmptyAPI' is simply 'EmptyClient'.+--+-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books+-- >         :<|> "nothing" :> EmptyAPI+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getAllBooks :: ClientM [Book]+-- > (getAllBooks :<|> EmptyClient) = client myApi+instance RunClient m => HasClient m EmptyAPI where+  type Client m EmptyAPI = EmptyClient+  clientWithRoute _pm Proxy _ = EmptyClient++-- | 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 'ToHttpApiData' instance for your type.+--+-- Example:+--+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getBook :: Text -> ClientM Book+-- > getBook = client myApi+-- > -- then you can just use "getBook" to query that endpoint+instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)+      => HasClient m (Capture capture a :> api) where++  type Client m (Capture capture a :> api) =+    a -> Client m api++  clientWithRoute pm Proxy req val =+    clientWithRoute pm (Proxy :: Proxy api)+                    (appendToPath p req)++    where p = (toUrlPiece val)++-- | If you use a 'CaptureAll' in one of your endpoints in your API,+-- the corresponding querying function will automatically take an+-- additional argument of a list of the type specified by your+-- 'CaptureAll'. 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 these values are turned into text by specifying+-- a 'ToHttpApiData' instance of your type.+--+-- Example:+--+-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile+-- >+-- > myApi :: Proxy+-- > myApi = Proxy+--+-- > getSourceFile :: [Text] -> ClientM SourceFile+-- > getSourceFile = client myApi+-- > -- then you can use "getSourceFile" to query that endpoint+instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)+      => HasClient m (CaptureAll capture a :> sublayout) where++  type Client m (CaptureAll capture a :> sublayout) =+    [a] -> Client m sublayout++  clientWithRoute pm Proxy req vals =+    clientWithRoute pm (Proxy :: Proxy sublayout)+                    (foldl' (flip appendToPath) req ps)++    where ps = map (toUrlPiece) vals++instance OVERLAPPABLE_+  -- Note [Non-Empty Content Types]+  ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)+  ) => HasClient m (Verb method status cts' a) where+  type Client m (Verb method status cts' a) = m a+  clientWithRoute _pm Proxy req = do+    response <- runRequest req+      { requestAccept = fromList $ toList accept+      , requestMethod = method+      }+    response `decodedAs` (Proxy :: Proxy ct)+    where+      accept = contentTypes (Proxy :: Proxy ct)+      method = reflectMethod (Proxy :: Proxy method)++instance OVERLAPPING_+  ( RunClient m, ReflectMethod method+  ) => HasClient m (Verb method status cts NoContent) where+  type Client m (Verb method status cts NoContent)+    = m NoContent+  clientWithRoute _pm Proxy req = do+    _response <- runRequest req { requestMethod = method }+    return NoContent+      where method = reflectMethod (Proxy :: Proxy method)++instance OVERLAPPING_+  -- Note [Non-Empty Content Types]+  ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls+  , ReflectMethod method, cts' ~ (ct ': cts)+  ) => HasClient m (Verb method status cts' (Headers ls a)) where+  type Client m (Verb method status cts' (Headers ls a))+    = m (Headers ls a)+  clientWithRoute _pm Proxy req = do+    response <- runRequest req+       { requestMethod = method+       , requestAccept = fromList $ toList accept+       }+    case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of+      Left err -> throwServantError $ DecodeFailure (pack err) response+      Right val -> return $ Headers+        { getResponse = val+        , getHeadersHList = buildHeadersTo . toList $ responseHeaders response+        }+      where method = reflectMethod (Proxy :: Proxy method)+            accept = contentTypes (Proxy :: Proxy ct)++instance OVERLAPPING_+  ( RunClient m, BuildHeadersTo ls, ReflectMethod method+  ) => HasClient m (Verb method status cts (Headers ls NoContent)) where+  type Client m (Verb method status cts (Headers ls NoContent))+    = m (Headers ls NoContent)+  clientWithRoute _pm Proxy req = do+    let method = reflectMethod (Proxy :: Proxy method)+    response <- runRequest req { requestMethod = method }+    return $ Headers { getResponse = NoContent+                     , getHeadersHList = buildHeadersTo . toList $ responseHeaders response+                     }+++-- | 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 'ToHttpApiData' instance.+--+-- Example:+--+-- > newtype Referer = Referer { referrer :: Text }+-- >   deriving (Eq, Show, Generic, ToHttpApiData)+-- >+-- >            -- GET /view-my-referer+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > viewReferer :: Maybe Referer -> ClientM Book+-- > viewReferer = client myApi+-- > -- then you can just use "viewRefer" to query that endpoint+-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)+      => HasClient m (Header sym a :> api) where++  type Client m (Header sym a :> api) =+    Maybe a -> Client m api++  clientWithRoute pm Proxy req mval =+    clientWithRoute pm (Proxy :: Proxy api)+                    (maybe req+                           (\value -> addHeader hname value req)+                           mval+                    )++    where hname = fromString $ symbolVal (Proxy :: Proxy sym)++-- | Using a 'HttpVersion' combinator in your API doesn't affect the client+-- functions.+instance HasClient m api+  => HasClient m (HttpVersion :> api) where++  type Client m (HttpVersion :> api) =+    Client m api++  clientWithRoute pm Proxy =+    clientWithRoute pm (Proxy :: Proxy api)++-- | Ignore @'Summary'@ in client functions.+instance HasClient m api => HasClient m (Summary desc :> api) where+  type Client m (Summary desc :> api) = Client m api++  clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)++-- | Ignore @'Description'@ in client functions.+instance HasClient m api => HasClient m (Description desc :> api) where+  type Client m (Description desc :> api) = Client m api++  clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)++-- | 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 'ToHttpApiData' instance for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getBooksBy :: Maybe Text -> ClientM [Book]+-- > getBooksBy = client myApi+-- > -- then you can just use "getBooksBy" to query that endpoint.+-- > -- 'getBooksBy Nothing' for all books+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)+      => HasClient m (QueryParam sym a :> api) where++  type Client m (QueryParam sym a :> api) =+    Maybe a -> Client m api++  -- if mparam = Nothing, we don't add it to the query string+  clientWithRoute pm Proxy req mparam =+    clientWithRoute pm (Proxy :: Proxy api)+                    (maybe req+                           (flip (appendToQueryString pname) req . Just)+                           mparamText+                    )++    where pname  = pack $ symbolVal (Proxy :: Proxy sym)+          mparamText = fmap toQueryParam 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 'ToHttpApiData' instance for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getBooksBy :: [Text] -> ClientM [Book]+-- > getBooksBy = client myApi+-- > -- then you can just use "getBooksBy" to query that endpoint.+-- > -- 'getBooksBy []' for all books+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'+-- > --   to get all books by Asimov and Heinlein+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)+      => HasClient m (QueryParams sym a :> api) where++  type Client m (QueryParams sym a :> api) =+    [a] -> Client m api++  clientWithRoute pm Proxy req paramlist =+    clientWithRoute pm (Proxy :: Proxy api)+                    (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))+                            req+                            paramlist'+                    )++    where pname = pack $ symbolVal (Proxy :: Proxy sym)+          paramlist' = map (Just . toQueryParam) 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 -> ClientM [Book]+-- > getBooks = client myApi+-- > -- then you can just use "getBooks" to query that endpoint.+-- > -- 'getBooksBy False' for all books+-- > -- 'getBooksBy True' to only get _already published_ books+instance (KnownSymbol sym, HasClient m api)+      => HasClient m (QueryFlag sym :> api) where++  type Client m (QueryFlag sym :> api) =+    Bool -> Client m api++  clientWithRoute pm Proxy req flag =+    clientWithRoute pm (Proxy :: Proxy api)+                    (if flag+                       then appendToQueryString paramname Nothing req+                       else req+                    )++    where paramname = pack $ symbolVal (Proxy :: Proxy sym)+++-- | Pick a 'Method' and specify where the server you want to query is. You get+-- back the full `Response`.+instance RunClient m => HasClient m Raw where+  type Client m Raw+    = H.Method ->  m Response++  clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw+  clientWithRoute _pm Proxy req httpMethod = do+    runRequest req { requestMethod = httpMethod }++-- | 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 -> ClientM Book+-- > addBook = client myApi+-- > -- then you can just use "addBook" to query that endpoint+instance (MimeRender ct a, HasClient m api)+      => HasClient m (ReqBody (ct ': cts) a :> api) where++  type Client m (ReqBody (ct ': cts) a :> api) =+    a -> Client m api++  clientWithRoute pm Proxy req body =+    clientWithRoute pm (Proxy :: Proxy api)+                    (let ctProxy = Proxy :: Proxy ct+                     in setRequestBodyLBS (mimeRender ctProxy body)+                                          -- We use first contentType from the Accept list+                                          (contentType ctProxy)+                                          req+                    )++-- | Make the querying function append @path@ to the request path.+instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where+  type Client m (path :> api) = Client m api++  clientWithRoute pm Proxy req =+     clientWithRoute pm (Proxy :: Proxy api)+                     (appendToPath p req)++    where p = pack $ symbolVal (Proxy :: Proxy path)++instance HasClient m api => HasClient m (Vault :> api) where+  type Client m (Vault :> api) = Client m api++  clientWithRoute pm Proxy req =+    clientWithRoute pm (Proxy :: Proxy api) req++instance HasClient m api => HasClient m (RemoteHost :> api) where+  type Client m (RemoteHost :> api) = Client m api++  clientWithRoute pm Proxy req =+    clientWithRoute pm (Proxy :: Proxy api) req++instance HasClient m api => HasClient m (IsSecure :> api) where+  type Client m (IsSecure :> api) = Client m api++  clientWithRoute pm Proxy req =+    clientWithRoute pm (Proxy :: Proxy api) req++instance HasClient m subapi =>+  HasClient m (WithNamedContext name context subapi) where++  type Client m (WithNamedContext name context subapi) = Client m subapi+  clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)++instance ( HasClient m api+         ) => HasClient m (AuthProtect tag :> api) where+  type Client m (AuthProtect tag :> api)+    = AuthenticatedRequest (AuthProtect tag) -> Client m api++  clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =+    clientWithRoute pm (Proxy :: Proxy api) (func val req)++-- * Basic Authentication++instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where+  type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api++  clientWithRoute pm Proxy req val =+    clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)+++{- Note [Non-Empty Content Types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Rather than have++   instance (..., cts' ~ (ct ': cts)) => ... cts' ...++It may seem to make more sense to have:++   instance (...) => ... (ct ': cts) ...++But this means that if another instance exists that does *not* require+non-empty lists, but is otherwise more specific, no instance will be overall+more specific. This in turn generally means adding yet another instance (one+for empty and one for non-empty lists).+-}
+ src/Servant/Client/Core/Internal/Request.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}++module Servant.Client.Core.Internal.Request where++import           Prelude                 ()+import           Prelude.Compat++import           Control.Monad.Catch     (Exception)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Lazy    as LBS+import           Data.Semigroup          ((<>))+import qualified Data.Sequence           as Seq+import           Data.Text               (Text)+import           Data.Text.Encoding      (encodeUtf8)+import           Data.Typeable           (Typeable)+import           GHC.Generics            (Generic)+import           Network.HTTP.Media      (MediaType)+import           Network.HTTP.Types      (Header, HeaderName, HttpVersion,+                                          Method, QueryItem, Status, http11,+                                          methodGet)+import           Web.HttpApiData         (ToHttpApiData, toEncodedUrlPiece,+                                          toHeader)++-- | A type representing possible errors in a request+--+-- Note that this type substantially changed in 0.12.+data ServantError =+  -- | The server returned an error response+    FailureResponse Response+  -- | The body could not be decoded at the expected type+  | DecodeFailure Text Response+  -- | The content-type of the response is not supported+  | UnsupportedContentType MediaType Response+  -- | The content-type header is invalid+  | InvalidContentTypeHeader Response+  -- | There was a connection error, and no response was received+  | ConnectionError Text+  deriving (Eq, Show, Generic, Typeable)++instance Exception ServantError++data RequestF a = Request+  { requestPath        :: a+  , requestQueryString :: Seq.Seq QueryItem+  , requestBody        :: Maybe (RequestBody, MediaType)+  , requestAccept      :: Seq.Seq MediaType+  , requestHeaders     :: Seq.Seq Header+  , requestHttpVersion :: HttpVersion+  , requestMethod      :: Method+  } deriving (Eq, Show, Functor, Generic, Typeable)++type Request = RequestF Builder.Builder++-- | The request body. Currently only lazy ByteStrings are supported.+newtype RequestBody = RequestBodyLBS LBS.ByteString+  deriving (Eq, Ord, Read, Show, Typeable)++data Response = Response+  { responseStatusCode  :: Status+  , responseBody        :: LBS.ByteString+  , responseHeaders     :: Seq.Seq Header+  , responseHttpVersion :: HttpVersion+  } deriving (Eq, Show, Generic, Typeable)++-- A GET request to the top-level path+defaultRequest :: Request+defaultRequest = Request+  { requestPath = ""+  , requestQueryString = Seq.empty+  , requestBody = Nothing+  , requestAccept = Seq.empty+  , requestHeaders = Seq.empty+  , requestHttpVersion = http11+  , requestMethod = methodGet+  }++appendToPath :: Text -> Request -> Request+appendToPath p req+  = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }++appendToQueryString :: Text       -- ^ param name+                    -> Maybe Text -- ^ param value+                    -> Request+                    -> Request+appendToQueryString pname pvalue req+  = req { requestQueryString = requestQueryString req+                        Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}++addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request+addHeader name val req+  = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}++-- | Set body and media type of the request being constructed.+--+-- The body is set to the given bytestring using the 'RequestBodyLBS'+-- constructor.+--+-- @since 0.12+--+setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request+setRequestBodyLBS b t req+  = req { requestBody = Just (RequestBodyLBS b, t) }++-- | Set body and media type of the request being constructed.+--+-- @since 0.12+--+setRequestBody :: RequestBody -> MediaType -> Request -> Request+setRequestBody b t req = req { requestBody = Just (b, t) }
+ src/Servant/Client/Core/Internal/RunClient.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+-- | Types for possible backends to run client-side `Request` queries+module Servant.Client.Core.Internal.RunClient where++import           Prelude                              ()+import           Prelude.Compat++import           Control.Monad                        (unless)+import           Data.Foldable                        (toList)+import           Data.Proxy                           (Proxy)+import qualified Data.Text                            as T+import           Network.HTTP.Media                   (MediaType, matches,+                                                       parseAccept, (//))+import           Servant.API                          (MimeUnrender,+                                                       contentTypes,+                                                       mimeUnrender)+import           Servant.Client.Core.Internal.Request (Request, Response (..),+                                                       ServantError (..))++class (Monad m) => RunClient m where+  -- | How to make a request.+  runRequest :: Request -> m Response+  throwServantError :: ServantError -> m a+  catchServantError :: m a -> (ServantError -> m a) -> m a++checkContentTypeHeader :: RunClient m => Response -> m MediaType+checkContentTypeHeader response =+  case lookup "Content-Type" $ toList $ responseHeaders response of+    Nothing -> return $ "application"//"octet-stream"+    Just t -> case parseAccept t of+      Nothing -> throwServantError $ InvalidContentTypeHeader response+      Just t' -> return t'++decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)+  => Response -> Proxy ct -> m a+decodedAs response contentType = do+  responseContentType <- checkContentTypeHeader response+  unless (any (matches responseContentType) accept) $+    throwServantError $ UnsupportedContentType responseContentType response+  case mimeUnrender contentType $ responseBody response of+    Left err -> throwServantError $ DecodeFailure (T.pack err) response+    Right val -> return val+  where+    accept = toList $ contentTypes contentType
+ src/Servant/Client/Core/Reexport.hs view
@@ -0,0 +1,30 @@+-- | This module is a utility for @servant-client-core@ backend writers. It+-- contains all the functionality from @servant-client-core@ that should be+-- re-exported.+module Servant.Client.Core.Reexport+  (+    -- * HasClient+    HasClient(..)+    -- * Response (for @Raw@)+  , Response(..)++  -- * Generic Client+  , ClientLike(..)+  , genericMkClientL+  , genericMkClientP+  , ServantError(..)+  , EmptyClient(..)++  -- * BaseUrl+  , BaseUrl(..)+  , Scheme(..)+  , showBaseUrl+  , parseBaseUrl+  , InvalidBaseUrlException+  ) where+++import           Servant.Client.Core.Internal.BaseUrl+import           Servant.Client.Core.Internal.HasClient+import           Servant.Client.Core.Internal.Generic+import           Servant.Client.Core.Internal.Request
+ test/Servant/Client/Core/Internal/BaseUrlSpec.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.Client.Core.Internal.BaseUrlSpec (spec) where+++import           Control.DeepSeq+import           Prelude ()+import           Prelude.Compat+import           Test.Hspec+import           Test.QuickCheck++import           Servant.Client.Core.Internal.BaseUrl++spec :: Spec+spec = do+  let parse = parseBaseUrl :: String -> Maybe BaseUrl+  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"+    it "shows the path of a BaseUrl" $ do+      showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api"+    it "shows the path of an https BaseUrl" $ do+      showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api"+    it "handles leading slashes in path" $ do+      showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api"++  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 (parse string )) True++    it "is the inverse of showBaseUrl" $ do+      property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $+        parse (showBaseUrl baseUrl) === Just baseUrl++    context "trailing slashes" $ do+      it "allows trailing slashes" $ do+        parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")++      it "allows trailing slashes in paths" $ do+        parse "foo.com/api/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")++    context "urls without scheme" $ do+      it "assumes http" $ do+        parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")++      it "allows port numbers" $ do+        parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "")++    it "can parse paths" $ do+      parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")++    it "rejects ftp urls" $ do+      parse "ftp://foo.com" `shouldBe` Nothing++instance Arbitrary BaseUrl where+  arbitrary = BaseUrl <$>+    elements [Http, Https] <*>+    hostNameGen <*>+    portGen <*>+    pathGen+   where+    letters = ['a' .. 'z'] ++ ['A' .. 'Z']+    -- this does not perfectly mirror the url standard, but I hope it's good+    -- enough.+    hostNameGen = do+      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)) :+      []+    pathGen = listOf1 . elements $ letters
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}