hreq-client (empty) → 0.1.0.0

raw patch · 15 files changed

+870/−0 lines, 15 filesdep +aesondep +basedep +base-compatbuild-type:Customsetup-changed

Dependencies added: aeson, base, base-compat, bytestring, containers, doctest, exceptions, hreq-client, hreq-core, hspec, http-client, http-client-tls, http-media, http-types, mtl, retry, stm, string-conversions, text, time, unliftio-core

Files

• CHANGELOG.md +3/−0
• LICENSE.md +21/−0
• README.md +7/−0
• Setup.hs +33/−0
• example/Main.hs +46/−0
• hreq-client.cabal +119/−0
• src/Hreq/Client.hs +217/−0
• src/Hreq/Client/Internal/Config.hs +42/−0
• src/Hreq/Client/Internal/HTTP.hs +191/−0
• test/DocTests.hs +14/−0
• test/Hreq/HttpBin/SuccessSpec.hs +24/−0
• test/Hreq/Pure/FailSpec.hs +25/−0
• test/Hreq/Pure/SuccessSpec.hs +74/−0
• test/Hreq/Pure/Util.hs +53/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,3 @@+## Hreq-Client 0.1.0.0++* Initial public release

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Lukwago Allan++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,7 @@+# Hreq++[![Hackage](https://img.shields.io/hackage/v/hreq.svg?logo=haskell)](https://hackage.haskell.org/package/hreq)+[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)+[![Build status](https://img.shields.io/travis/epicallan/hreq.svg?logo=travis)](https://travis-ci.org/epicallan/hreq)++Implementation of Hreq Client. An HTTP client basing on hreq-core. Please look at the repository [README.md](https://github.com/epicallan/hreq/blob/master/README.md) file for more.

@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+         The doctests test-suite will not work as a result. \+         To fix this, install cabal-doctest before configuring.+#endif++import Distribution.Simple++main :: IO ()+main = defaultMain++#endif

@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE TypeOperators     #-}+module Main where++import Control.Monad.IO.Class (liftIO)+import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import GHC.Generics (Generic)+import Hreq.Client++data User = User+  { name :: Text+  , age  :: Int+  } deriving (Show, Generic, ToJSON, FromJSON)++-- | Assume we are making requests against an HTTP service providing a JSON user management API+--+baseUrl :: BaseUrl+baseUrl = HttpUrl "example.com" "user"++getUserByName :: RunClient m => Text -> m User+getUserByName userName = hreq @(Capture Text :> GetJson User) (userName :. Empty)++getAllUsers :: RunClient m => m [User]+getAllUsers = hreq @("all" :> GetJson [User]) Empty++createUser :: RunClient m => User -> m ()+createUser user = hreq @(JsonBody User :> EmptyResponse POST) (user :. Empty)++-- | Don't run main without supplying a functioning baseUrl.+main :: IO ()+main = runHreq baseUrl $ do+  reqUser     <- getUserByName "allan"+  createdUser <- createUser newUser+  allUsers    <- getAllUsers+  -- Delete users with age equal to 20+  hreq @(Capture Int :> EmptyResponse DELETE) (20 :. Empty)+  -- do something with API data+  liftIO $ print (reqUser, createdUser, allUsers)+  where+    newUser :: User+    newUser = User "allan" 12

@@ -0,0 +1,119 @@+cabal-version: >= 2.0+name:           hreq-client+version:        0.1.0.0+synopsis:       A Type dependent Highlevel HTTP client library.+description:    A Type dependent highlevel HTTP client library inspired by servant-client.+category:       Network, Web+homepage:       https://github.com/epicallan/hreq/blob/master/README.md+bug-reports:    https://github.com/epicallan/hreq.git/issues+author:         Lukwago Allan <epicallan.al@gmail>+maintainer:     Lukwago Allan <epicallan.al@gmail>+copyright:      2019 Lukwago Allan+license:        MIT+license-file:   LICENSE.md+extra-doc-files: CHANGELOG.md, README.md+tested-with:+   GHC  ==8.2.2+    ||  ==8.4.4+    ||  ==8.6.5+    ||  ==8.8.1+build-type: Custom++source-repository head+  type: git+  location: https://github.com/epicallan/hreq.git++custom-setup+ setup-depends:+   base >= 4 && <5,+   Cabal,+   cabal-doctest >= 1 && <1.1++library+  exposed-modules:+      Hreq.Client+    , Hreq.Client.Internal.Config+    , Hreq.Client.Internal.HTTP++  default-extensions: LambdaCase DeriveGeneric FlexibleInstances FlexibleContexts ScopedTypeVariables TypeApplications TypeOperators MultiParamTypeClasses RecordWildCards TypeApplications TypeFamilies OverloadedStrings GADTs GeneralizedNewtypeDeriving FunctionalDependencies ConstraintKinds RankNTypes PolyKinds DataKinds KindSignatures ViewPatterns UndecidableInstances StrictData++  build-depends:+    base                 >= 4.10.1 && < 5,+    base-compat          >= 0.10.5 && < 0.13,+    bytestring           >= 0.10.8 && < 0.11,+    containers           >= 0.5.7.1 && < 0.7,+    exceptions           >= 0.10.0 && < 0.11,+    http-client          >= 0.6.4 && < 0.7,+    http-client-tls      >= 0.3.5 && < 0.4,+    hreq-core            >= 0.1.0,+    http-media           >= 0.8.0 && < 0.9,+    http-types           >= 0.12.3 && < 0.13,+    mtl                  >= 2.2.2 && < 3.0,+    retry                >= 0.8   && < 0.9,+    time                 >= 1.6.0.1 && < 2.0,+    text                 >= 1.2.4 && < 1.3,+    stm                  >= 2.4.5.1 && < 2.6,+    unliftio-core        >= 0.1.2 && < 0.2.0,+    string-conversions   >= 0.4.0 && < 0.5++  ghc-options:+    -Wall+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -Wcompat+    -Widentities+    -Wredundant-constraints+    -fhide-source-paths+    -freverse-errors+    -Wpartial-fields++  hs-source-dirs: src+  default-language: Haskell2010++executable example+  main-is: Main.hs+  hs-source-dirs: example+  ghc-options: -Wall+  default-language: Haskell2010+  build-depends:+      base >= 4.10.1 && < 5+    , hreq-client+    , aeson  >= 1.4.5 && < 1.5+    , text  >= 1.2.4 && < 1.3++test-suite spec+  build-depends:+      base       >= 4.10.1 && < 5+    , aeson      >= 1.4.5  && < 1.5+    , containers >= 0.5.7.1 && < 0.7+    , http-types >= 0.12.3 && < 0.13+    , hspec      >= 2.6.0  && < 2.8+    , hreq-client+    , hreq-core+  main-is:             Spec.hs+  hs-source-dirs:      test+  type:                exitcode-stdio-1.0+  ghc-options:         -Wall -threaded+  default-language:    Haskell2010+  default-extensions: LambdaCase DeriveGeneric FlexibleInstances FlexibleContexts ScopedTypeVariables TypeApplications TypeOperators MultiParamTypeClasses RecordWildCards TypeApplications TypeFamilies OverloadedStrings GADTs GeneralizedNewtypeDeriving FunctionalDependencies ConstraintKinds RankNTypes PolyKinds DataKinds KindSignatures ViewPatterns StrictData+  other-modules:+      Hreq.Pure.FailSpec+    , Hreq.Pure.Util+    , Hreq.Pure.SuccessSpec+    , Hreq.HttpBin.SuccessSpec++  build-tool-depends:+    hspec-discover:hspec-discover >= 2.6.0 && <2.8++test-suite doctests+  type:             exitcode-stdio-1.0+  main-is:          DocTests.hs+  build-depends:+      base       >= 4.10.1 && < 5+    , aeson      >= 1.4.5 && < 1.5+    , doctest    >=0.15 && < 0.17+    , hreq-client++  ghc-options:      -Wall -threaded+  hs-source-dirs:   test+  default-language: Haskell2010

@@ -0,0 +1,217 @@+-- | Hreq is a high-level easy to use type-driven HTTP client library inspired by Servant-Client.+-- Hreq provides an alternative approach to type-safe construction and interpretation of API+-- endpoints for Http client requests.+-- Hreq is greatly inspired by Servant Client.+--+-- == Examples+--+-- Assume we are making requests against an HTTP service providing a JSON user management API.+--+-- > {-# LANGUAGE DataKinds         #-}+-- > {-# LANGUAGE DeriveAnyClass    #-}+-- > {-# LANGUAGE DeriveGeneric     #-}+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE TypeApplications  #-}+-- > {-# LANGUAGE TypeOperators     #-}+-- >+-- > import Control.Monad.IO.Class (liftIO)+-- > import Data.Aeson (FromJSON, ToJSON)+-- > import Data.Text (Text)+-- > import GHC.Generics (Generic)+-- > import Hreq.Client+-- >+-- > data User = User+-- >  { name :: Text+-- >  , age  :: Int+-- >  } deriving (Show, Generic, FromJSON, ToJSON)+--+-- @User@ service API URL+--+-- > baseUrl :: BaseUrl+-- > baseUrl = HttpUrl "example.com" "user"+--+-- ===Simple Get request+--+-- Make a Get request obtaining a @User@ by a specified @user-name@ at <http://example.com/user/:userName>+--+-- > getUserByName :: RunClient m => Text -> m User+-- > getUserByName userName = hreq @(Capture Text :> GetJson User) (userName :. Empty)+--+-- The @Capture Text :> GetJson User@ type with in @getUserByName@ is an API endpoint type definition.+--+-- The API type definition in this instance demands that a heterogeneous list containing a 'Text' value is supplied to the 'hreq' function.+--+-- @userName ':.' 'Empty'@ forms the required heterogeneous list value for the 'hreq' function.+-- Finally, the API type states that we will obtain a 'JSON' @User@ response output.+--+-- ===Simple Post request+--+-- Make a Post request with Json User data for a request body returning a Json User response at <http://example.com/user>+--+-- > createUser :: RunClient m => User -> m ()+-- > createUser user = hreq @(JsonBody User :> EmptyResponse POST) (user :. Empty)+--+-- ===Get Request with QueryFlag+--+-- Make a Get requesting obtaining all users at API endpoint <http://example.com/user/all?old>+--+-- > getAllUsers :: RunClient m => m [User]+-- > getAllUsers = hreq @("all" :> QueryFlag "old" :> GetJson [User]) Empty+--+-- ===Running api endpoint functions+--+-- With in the main function; the API endpoint functions run within the 'Hreq' monad.+-- The Hreq monad has an instance of the 'RunClient' class and 'MonadIO' class.+--+-- > main :: IO ()+-- > main = runHreq baseUrl $ do+-- >  reqUser     <- getUserByName "allan"+-- >  createdUser <- createUser newUser+-- >  allUsers    <- getAllUsers+-- > --Delete users with age equal to 20+-- >  hreq @(Capture Int :> EmptyResponse DELETE) (20 :. Empty)+-- >  -- do something with API data+-- >  liftIO $ print (reqUser, createdUser, allUsers)+-- >  where+-- >    newUser :: User+-- >    newUser = User "allan" 12+--+-- ==More examples+--+-- ====Appending a path to the request path+--+-- >>> type PathsQuery = "user" :> "allan" :> GetJson User+--+-- > pathsExample :: RunClient m => m User+--+-- >>> pathsExample = hreq @PathsQuery Empty+--+-- ====Adding query params to a request+--+-- Any type with a 'ToHttpApiData' class instance can be used as a Param value type.+--+-- >>> type SingleParam = Param "name" String :> GetJson User+--+-- > singleParamExample :: RunClient m => m Response+--+-- >>> singleParamsExample =  hreq @SingleParam ("allan" :. Empty)+--+-- >>> type MultiParams = Param "name" String :> Param "age" Int :> GetJson User+--+-- >>> type MultiParamsList = Params '["name" := String, "age" := Int] :> GetJson User+--+-- > -- Note MultiParams and MultiParamsList are the same.+-- > -- Resulting URL is of the form http://example.com/api?name="allan"&age=20+--+-- > multiParamsExample :: RunClient m => m User+--+-- >>> multiParamsExample = hreq @MultiParams ("allan" :. 20 :. Empty)+--+-- ====Adding QueryFlags to a request+--+-- >>> type SingleQueryFlag = "user" :> QueryFlag "male" :> GetJson User+--+-- > singleQueryFlag :: RunClient m => m User+--+-- >>> singleQueryFlag = hreq @SingleQueryFlag Empty+--+-- >>> type MultiQueryFlags = "user" :> QueryFlag "male" :> QueryFlag "old" :> GetJson User+--+-- >>> type MultiQueryFlagList = "user" :> QueryFlags '["male", "old"] :> GetJson User+--+-- > -- Note MultiQueryFlags and MultiQueryFlagsList are the same+-- > -- The query flag values are inferred from provided type level strings (symbols)+-- > -- Resulting URL is of the form http://example.com/api?male&old+--+-- > multiFlagsExample :: RunClient m => m User+--+-- >>> multiFlagsExample = hreq @MultiQueryFlagList Empty+--+-- ====Adding Captures+--+-- Any type with a 'ToHttpApiData' class instance can be used as a 'Capture' value type.+--+-- >>> type SingleCapture = Capture UserName :> GetJson User+--+-- >>> type MultiCapturesList = "users" :> Captures '[UserName, UserAge] :> GetJson User+-- >>> type MultiCaptures = "users" :> Capture UserName :> Capture UserAge :> GetJson User+--+-- > -- Resulting URL is of the form http://example.com/users/allan/12+-- > -- Note that MultiCapturesList is equal to MultiCaptures.+--+-- > captureExample :: RunClient m => m User+--+-- >>> captureExample =  hreq @MultiCaptures $ UserName "allan" :. UserAge 12 :. Empty+--+-- =====CaptureAll+--+-- 'CaptureAll' is useful for a specifying a request composed of multiple URL parameter fragments of the+-- same type in a concise manner.+--+-- >>> type CaptureAllExample = "users" :> CaptureAll String :> GetJson User+--+-- > captureAllExample :: RunClient m => m User+--+-- >>> captureAllExample = hreq @CaptureAllExample $ ["allan",  "alex", "brian"] :. Empty+--+-- ====Adding a Request body+--+-- Request bodies are created by the 'ReqBody' type. A request body type is encoded to+-- into a byteString basing on the provided media/mime type.+--+-- The library nativelysupports some media types such as 'JSON' and 'PlainText' among others.+--+-- Example type using JSON as media type, the provided body type should have an Aeson @ToJSON@ instance+--+-- >>> type ReqBodyQuery = "users" :> ReqBody User JSON :> GetJson User+--+-- The above query can be written as below:+--+-- >>> type JsonBodyQuery = "users" :> JsonBody User :> GetJson User+--+-- ==== Response type Examples+--+-- Response are represented by the @'Verb' (method :: k1) (contents:: [k2])@ type.+--+-- @method@ : is a Standard HTTP verb type such as 'GET' or 'POST'+-- @contents@ : is a type level list containing expected response from making an http call.+--+-- The library provides convenience type synonyms out of the Verb type such as @GetJson@, @PostJson@ etc.+--+-- >>> type GetPlainText a = Get '[ResBody PlainText a]+--+-- > plainTextResponse :: RunClient m => m String+--+-- >>> plainTextResponse = hreq @("user" :> GetPlainText String) Empty+--+-- =====Returning multiple values Example+--+-- >>> type MultiResultsQuery = Get '[ ResBody JSON User, ResHeaders '[ "key-header" := String ] ]+--+-- > multiResults :: RunClient m => m (Hlist '[ User, [Header] ])+--+-- >>> multiResults = hreq @MultiResultsQuery Empty+--+module Hreq.Client+  ( module Hreq.Core.API+  , module Hreq.Core.Client+  , module Hreq.Client.Internal.HTTP+  , module Hreq.Client.Internal.Config+  ) where++import Hreq.Client.Internal.Config (HttpConfig (..), StatusRange (..), createDefConfig)+import Hreq.Client.Internal.HTTP (Hreq (..), RunClient (..), runHreq, runHreqWithConfig)++import Hreq.Core.API+import Hreq.Core.Client++-- $setup+-- >>> import Hreq.Core.API+-- >>> import GHC.Generics+-- >>> import Data.Aeson+-- >>> import Data.Hlist+-- >>> data User = User deriving (Show)+-- >>> instance ToJSON User where toJSON = undefined+-- >>> instance FromJSON User where parseJSON = undefined+-- >>> newtype UserName = UserName { unUserName :: String } deriving (Show, ToHttpApiData)+-- >>> newtype UserAge = UserAge { unUserAge :: Int } deriving (Show, ToHttpApiData)

@@ -0,0 +1,42 @@+-- | 'HttpConfig' is used in the 'Hreq.Client.Internal.HTTP.Hreq' Monad for HTTP client configuration+--+module Hreq.Client.Internal.Config+  ( -- * HttpConfig+    HttpConfig (..)+    -- * Status Range+  , StatusRange (..)+    -- * Helper function+  , createDefConfig+  ) where++import Control.Concurrent.STM.TVar (TVar)+import Control.Retry (RetryPolicy, retryPolicyDefault)+import qualified Network.HTTP.Client as C+import qualified Network.HTTP.Client.TLS as TLS++import Hreq.Core.API (StatusCode)+import Hreq.Core.Client++-- | Valid Response status code range+data StatusRange = StatusRange+  { statusUpper :: StatusCode+  , statusLower :: StatusCode+  }++data HttpConfig = HttpConfig+  { httpBaseUrl     :: BaseUrl+  , httpStatuses    :: StatusRange+  , httpCookieJar   :: Maybe (TVar C.CookieJar)+  , httpRetryPolicy :: RetryPolicy+  , httpManager     :: C.Manager+  }++-- | Function for creating a default 'HttpConfig'+createDefConfig :: BaseUrl -> IO HttpConfig+createDefConfig baseUrl@(BaseUrl scheme _ _ _) =+  HttpConfig baseUrl (StatusRange 200 300) Nothing retryPolicyDefault <$> manager+  where+    manager :: IO C.Manager+    manager = case scheme of+       Http  -> C.newManager C.defaultManagerSettings+       Https -> C.newManager TLS.tlsManagerSettings

@@ -0,0 +1,191 @@+-- | This module provides functionality for running the 'Hreq' Monad as an HTTP client+-- and the necessary required class instances, such as 'RunClient' instance.+--+{-# LANGUAGE TupleSections #-}+module Hreq.Client.Internal.HTTP+  ( -- * Hreq monad+    Hreq (..)+  , RunClient (..)+    -- * Running Hreq+  , runHreq+  , runHreqWithConfig+  , runHttpClient+    -- * Helper functions+  , checkHttpResponse+  , requestToHTTPRequest+  , httpResponsetoResponse+  , catchConnectionError+  ) where++import Prelude ()+import Prelude.Compat++import Control.Concurrent.STM.TVar (TVar, modifyTVar', readTVar, writeTVar)+import Control.Monad.Catch (SomeException (..), catch, throwM)+import Control.Monad.IO.Unlift (MonadUnliftIO (..), wrappedWithRunInIO)+import Control.Monad.Reader (MonadIO (..), MonadReader, MonadTrans, ReaderT (..), ask, asks)+import Control.Monad.STM (STM, atomically)+import Control.Retry (retrying)+import qualified Data.ByteString.Lazy as LBS+import Data.Either (isLeft)+import Data.Foldable (toList)+import Data.Maybe (maybeToList)+import Data.String.Conversions (cs)+import Data.Time.Clock (UTCTime, getCurrentTime)+import GHC.Natural (Natural)+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Media (renderHeader)+import Network.HTTP.Types (Header, hAccept, hContentType, renderQuery, statusCode, statusMessage)++import Hreq.Client.Internal.Config (HttpConfig (..), StatusRange (..), createDefConfig)+import Hreq.Core.API (GivesPooper (..))+import Hreq.Core.Client (BaseUrl (..), ClientError (..), Request, RequestBody (..), RequestF (..),+                         Response, ResponseF (..), RunClient (..), Scheme (..))++-- | Monad for running Http client requests+newtype Hreq m a = Hreq { runHreq' :: ReaderT HttpConfig m a }+  deriving (Functor, Applicative, Monad, MonadReader HttpConfig, MonadTrans, MonadIO)++instance MonadUnliftIO m => MonadUnliftIO (Hreq m) where+  withRunInIO = wrappedWithRunInIO Hreq runHreq'++instance RunClient (Hreq IO) where+  runClient = runHttpClient++  throwHttpError = Hreq . throwM++  checkResponse = checkHttpResponse++runHreq :: MonadIO m => BaseUrl -> Hreq m a -> m a+runHreq baseUrl action = do+  config <- liftIO $ createDefConfig baseUrl++  runHreqWithConfig config action++runHreqWithConfig :: HttpConfig -> Hreq m a -> m a+runHreqWithConfig config action = runReaderT (runHreq' action) config++runHttpClient+  :: (MonadReader HttpConfig m, MonadIO m, RunClient m)+  => Request+  -> m Response+runHttpClient req = do+  config <- ask++  let manager = httpManager config+  let baseUrl = httpBaseUrl config+  let mcookieJar = httpCookieJar config+  let retryPolicy = httpRetryPolicy config++  let httpRequest = requestToHTTPRequest baseUrl req++  let requestAction = liftIO $ catchConnectionError+        $ performHttpRequest httpRequest manager mcookieJar++  ehttpResponse <- retrying retryPolicy (const (return . isLeft) ) (const requestAction)++  response <- either throwHttpError (pure . httpResponsetoResponse cs) ehttpResponse++  maybe (pure response) throwHttpError =<< checkResponse req response++checkHttpResponse+  :: (MonadReader HttpConfig m)+  => Request+  -> Response+  -> m (Maybe ClientError)+checkHttpResponse req response = do+  statusRange <- asks httpStatuses+  let code = resStatusCode response+  pure $ if code >= statusLower statusRange && code <= statusUpper statusRange+    then Just $ FailureResponse req response+    else Nothing++-- * Helper functions+performHttpRequest+  :: HTTP.Request+  -> HTTP.Manager+  -> Maybe (TVar HTTP.CookieJar)+  -> IO (HTTP.Response LBS.ByteString)+performHttpRequest request manager mcookieJar = case mcookieJar of+  Nothing -> HTTP.httpLbs request manager+  Just cj -> do+    req' <- cookieJarRequest cj request+    HTTP.withResponseHistory req' manager $ updateWithResponseCookies cj+  where+    cookieJarRequest :: TVar HTTP.CookieJar -> HTTP.Request -> IO HTTP.Request+    cookieJarRequest cj req = do+      now <- getCurrentTime+      atomically $ do+        oldCookieJar <- readTVar cj+        let (newReq, newCookieJar) = HTTP.insertCookiesIntoRequest req oldCookieJar now+        writeTVar cj newCookieJar+        pure newReq++    -- updateWithResponseCookies code is borrowed from @servant-client@+    updateWithResponseCookies+      :: TVar HTTP.CookieJar+      -> HTTP.HistoriedResponse HTTP.BodyReader+      -> IO (HTTP.Response LBS.ByteString)+    updateWithResponseCookies cj responses = do+        now <- getCurrentTime+        bss <- HTTP.brConsume $ HTTP.responseBody fRes+        let fRes'        = fRes { HTTP.responseBody = LBS.fromChunks bss }+            allResponses = HTTP.hrRedirects responses <> [(fReq, fRes')]+        atomically $ mapM_ (updateCookieJar now) allResponses+        return fRes'+      where+          updateCookieJar :: UTCTime -> (HTTP.Request, HTTP.Response LBS.ByteString) -> STM ()+          updateCookieJar now' (req', res') = modifyTVar' cj (fst . HTTP.updateCookieJar res' req' now')++          fReq = HTTP.hrFinalRequest responses+          fRes = HTTP.hrFinalResponse responses++httpResponsetoResponse :: (a -> b) -> HTTP.Response a -> ResponseF b+httpResponsetoResponse f response = Response+ { resStatusCode = statusCode $ HTTP.responseStatus response+ , resStatusMsg = cs $ statusMessage $ HTTP.responseStatus response+ , resHeaders = HTTP.responseHeaders response+ , resBody = f $ HTTP.responseBody response+ , resHttpVersion = HTTP.responseVersion response+ }++requestToHTTPRequest :: BaseUrl -> Request -> HTTP.Request+requestToHTTPRequest burl r = HTTP.defaultRequest+    { HTTP.method = reqMethod r+    , HTTP.host = cs $ baseUrlHost burl+    , HTTP.port = fromIntegral @Natural @Int $ baseUrlPort burl+    , HTTP.path = cs $ baseUrlPath burl <> reqPath r+    , HTTP.queryString = renderQuery True $ toList $ reqQueryString r+    , HTTP.requestHeaders = maybeToList acceptHeader <> maybeToList contentType <> headers+    , HTTP.requestBody = body+    , HTTP.secure = isSecure+    }+  where+    headers :: [ Header ]+    headers = filter ( \(hname, _) -> hname /= hAccept && hname /= hContentType)+            $ toList $ reqHeaders r++    acceptHeader :: Maybe Header+    acceptHeader = (hAccept, ) . renderHeader <$> reqAccept r++    (body, contentType) = case reqBody r of+      Nothing -> (HTTP.RequestBodyBS mempty, Nothing)+      Just (body', ctyp) ->+        let addBody = (, Just (hContentType, renderHeader ctyp))+        in case body' of+          RequestBodyBS bs ->+            addBody $ HTTP.RequestBodyBS bs+          RequestBodyLBS lbs ->+            addBody $ HTTP.RequestBodyLBS lbs+          RequestBodyStream (GivesPooper givesPooper) ->+            addBody $ HTTP.RequestBodyStreamChunked givesPooper++    isSecure :: Bool+    isSecure = case baseUrlScheme burl of+        Http  -> False+        Https -> True++catchConnectionError :: IO a -> IO (Either ClientError a)+catchConnectionError action =+  catch (Right <$> action)+    $ \e -> pure . Left . ConnectionError $ SomeException (e :: HTTP.HttpException)

@@ -0,0 +1,14 @@+module Main where++import Build_doctests (flags, module_sources, pkgs)+import Data.Foldable (traverse_)+import System.Environment (unsetEnv)+import Test.DocTest (doctest)++main :: IO ()+main = do+    traverse_ putStrLn args -- optionally print arguments+    unsetEnv "GHC_ENVIRONMENT" -- see 'Notes'; you may not need this+    doctest args+  where+    args = flags ++ pkgs ++ module_sources

@@ -0,0 +1,24 @@+module Hreq.HttpBin.SuccessSpec (spec) where++import Data.Aeson+import Hreq.Client+import Test.Hspec++spec :: Spec+spec = describe "Hreq.HttpBin.SuccessSpec" successSpec++successSpec :: Spec+successSpec = do+  let baseUrl = HttpsDomain "httpbin.org"+      runHttpBin = runHreq baseUrl++  describe "Works with HttpBin" $ do+    it "works with get requests" $ do+       r  <- runHttpBin $ hreq @("get" :> RawResponse GET) Empty+       resStatusCode r `shouldBe` 200++    it "works with post requests" $ do+       r  <- runHttpBin+               $ hreq @("post" :> JsonBody String :> PostJson Value) ("foo" :. Empty)++       show r `shouldContain` "foo"

@@ -0,0 +1,25 @@+module Hreq.Pure.FailSpec (spec) where++import Hreq.Client+import Hreq.Pure.Util (TestState (..), TestUser, defaultResponse, runClientPure)+import Test.Hspec++spec :: Spec+spec = describe "Hreq.FailSpec" failSpec++failSpec :: Spec+failSpec = do+  let baseUrl = HttpDomain "example.com"++  describe "throw appropriate errors" $ do+    it "throw failure error" $ do+      let x = hreq @("hello" :> RawResponse GET) Empty+          req' = appendToPath "hello" defaultRequest+      runClientPure @'FailureState baseUrl x+        `shouldBe` Throw (FailureResponse req' defaultResponse)++    it "throws decoding failure error" $ do+      let x = hreq @(GetJson TestUser) Empty++      show (runClientPure @'DecodingErrorState baseUrl x)+        `shouldContain` "DecodeFailure"

@@ -0,0 +1,74 @@+module Hreq.Pure.SuccessSpec (spec) where++import Data.Foldable+import Data.Proxy+import Test.Hspec++import Hreq.Client+import Hreq.Core.Client (RequestBody (..))+import Hreq.Pure.Util (TestState (..), TestUser (..), defaultResponse, runClientPure)++spec :: Spec+spec = describe "Hreq.SuccessSpec" successSpec++testUser :: TestUser+testUser = TestUser "Allan" 29++successSpec :: Spec+successSpec = do+  let baseUrl = HttpDomain "example.com"+      runClientPure' = runClientPure @'Default++  describe "Works with request components" $ do+    it "works with paths" $ do+       let x = hreq @("hello" :> RawResponse GET) Empty+           expected = RunClient (appendToPath "hello" defaultRequest) defaultResponse+       runClientPure' baseUrl x `shouldBe` expected++    it "works with request body" $ do+      let x = hreq @(JsonBody TestUser :> RawResponse GET) (testUser :. Empty)+          RunClient req _ = runClientPure' baseUrl x+          Just (RequestBodyLBS body, _ )  = reqBody req+      body `shouldBe` mediaEncode (Proxy @JSON) testUser++    it "works with query flags" $ do+      let x = hreq @("users" :> QueryFlag "male" :> QueryFlag "old" :> RawResponse GET) Empty+          RunClient req _ = runClientPure @'Default baseUrl x+      reqPath req `shouldBe` "/users"+      toList (reqQueryString req) `shouldBe` [("male", Nothing), ("old", Nothing)]++    it "works with capture" $ do+      let x = hreq @(Capture String :> RawResponse GET) ("allan" :. Empty)+          RunClient req _ = runClientPure @'Default baseUrl x+      reqPath req `shouldBe` "/allan"++    it "works with captureAll" $ do+      let x = hreq @(CaptureAll String :> RawResponse GET) (["allan", "lukwago"] :. Empty)+          RunClient req _ = runClientPure @'Default baseUrl x+      reqPath req `shouldBe` "/allan/lukwago"++    it "works with single query params" $ do+      let x = hreq @(Param "name" String :> RawResponse GET) ("allan" :. Empty)+          RunClient req _ = runClientPure @'Default baseUrl x+      toList (reqQueryString req) `shouldBe` [("name", Just "allan")]++    it "works with multi query params" $ do+      let x = hreq @(Param "name" String :> Param "age" Int :> RawResponse GET) ("allan" :. 29 :. Empty)+          RunClient req _ = runClientPure @'Default baseUrl x+      toList (reqQueryString req) `shouldBe`  [("name", Just "allan"), ("age", Just "29")]++    it "works with multi query params as a list" $ do+      let x = hreq @(Params '["name" := String, "age" := Int] :> RawResponse GET) ("allan" :. 29 :. Empty)+          RunClient req _ = runClientPure @'Default baseUrl x+      toList (reqQueryString req) `shouldBe`  [("name", Just "allan"), ("age", Just "29")]++  describe "Works with response components" $ do+    it "works with single verb requests" $ do+      let x = hreq @(RawResponse GET) Empty+          expected = RunClient defaultRequest defaultResponse+      runClientPure' baseUrl x `shouldBe` expected++    it "works with JSON responses" $ do+       let x = hreq @(GetJson TestUser) Empty+           RunClient _ res = runClientPure @'Default baseUrl x+       res `shouldBe` testUser

@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveAnyClass #-}+module Hreq.Pure.Util where++import Data.Aeson+import GHC.Generics++import Hreq.Client+import Network.HTTP.Types (hContentType, http11)++defaultResponse :: Response+defaultResponse = Response+ { resStatusCode = 200+ , resStatusMsg = "Ok"+ , resHeaders = [(hContentType, "application/json")]+ , resHttpVersion = http11+ , resBody = "{\"name\":\"Allan\",\"age\":29}"+ }++data TestState =+    FailureState+  | DecodingErrorState+  | Default++setClientRequest :: Request -> ClientPure state a -> ClientPure state a+setClientRequest r h = case h of+  RunClient _ rs -> RunClient r rs+  Throw e        -> Throw e++instance RunClient (ClientPure 'Default) where+  runClient req       = RunClient req defaultResponse+  throwHttpError      = Throw+  checkResponse req _ = RunClient req Nothing++instance RunClient (ClientPure 'FailureState) where+  runClient req       = Throw $ FailureResponse req defaultResponse+  throwHttpError      = Throw+  checkResponse req _ = RunClient req Nothing++instance RunClient (ClientPure 'DecodingErrorState) where+  runClient req       = RunClient req (defaultResponse { resBody = "hey" })+  throwHttpError      = Throw+  checkResponse req _ = RunClient req Nothing++runClientPure+  :: forall state a. (Show a, Eq a)+  => BaseUrl -> ClientPure state a -> ClientPure state a+runClientPure _ httpClient = httpClient++-- Test data+data TestUser = TestUser+  { name :: String+  , age  :: Int+  } deriving (Show, Eq, Generic, ToJSON, FromJSON)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}