diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Hreq-Client 0.1.0.0 + +* Initial public release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 diff --git a/hreq-client.cabal b/hreq-client.cabal new file mode 100644 --- /dev/null +++ b/hreq-client.cabal @@ -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 +maintainer: Lukwago Allan +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 diff --git a/src/Hreq/Client.hs b/src/Hreq/Client.hs new file mode 100644 --- /dev/null +++ b/src/Hreq/Client.hs @@ -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 +-- +-- > 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 +-- +-- > 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 +-- +-- > 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) diff --git a/src/Hreq/Client/Internal/Config.hs b/src/Hreq/Client/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hreq/Client/Internal/Config.hs @@ -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 diff --git a/src/Hreq/Client/Internal/HTTP.hs b/src/Hreq/Client/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Hreq/Client/Internal/HTTP.hs @@ -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) diff --git a/test/DocTests.hs b/test/DocTests.hs new file mode 100644 --- /dev/null +++ b/test/DocTests.hs @@ -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 diff --git a/test/Hreq/HttpBin/SuccessSpec.hs b/test/Hreq/HttpBin/SuccessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hreq/HttpBin/SuccessSpec.hs @@ -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" diff --git a/test/Hreq/Pure/FailSpec.hs b/test/Hreq/Pure/FailSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hreq/Pure/FailSpec.hs @@ -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" diff --git a/test/Hreq/Pure/SuccessSpec.hs b/test/Hreq/Pure/SuccessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hreq/Pure/SuccessSpec.hs @@ -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 diff --git a/test/Hreq/Pure/Util.hs b/test/Hreq/Pure/Util.hs new file mode 100644 --- /dev/null +++ b/test/Hreq/Pure/Util.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}