{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-- |
-- Module : Effectful.HttpClient
-- Copyright : (c) 2026 Institute for Digital Autonomy
-- License : EUPL-1.2
-- Maintainer : IDA
--
-- Effectful bindings for the <http://hackage.haskell.org/package/http-client http-client library>.
--
-- @http-client@ works best when you create one 'Manager' and reuse it
-- everywhere, since each 'Manager' has its own connection pool and isn't cheap to set up.
-- This module makes that pattern effortless:
-- 'runHttpClient' or 'runHttpClientTls' creates the 'Manager' once,
-- and every request you make within that scope implicitly reuses it.
--
-- = Example Usage
--
-- === Making a GET request
--
-- > import Effectful
-- > import Effectful.HttpClient
-- > import Network.HTTP.Types.Status (statusCode)
-- >
-- > main :: IO ()
-- > main = runEff . runHttpClientTls $ do
-- > request <- parseRequest "http://httpbin.org/get"
-- > response <- httpLbs request
-- >
-- > liftIO . putStrLn $ "The status code was: " <> (show $ statusCode $ responseStatus response)
-- > liftIO . print $ responseBody response
--
--
-- === Posting JSON to a server
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > import Effectful
-- > import Effectful.HttpClient
-- > import Network.HTTP.Types.Status (statusCode)
-- > import Data.Aeson (object, (.=), encode)
-- > import Data.Text (Text)
-- >
-- > main :: IO ()
-- > main = runEff . runHttpClientTls $ do
-- > -- Create the request
-- > let requestObject = object
-- > [ "name" .= ("Ueli" :: Text)
-- > , "age" .= (30 :: Int)
-- > ]
-- >
-- > initialRequest <- parseRequest "http://httpbin.org/post"
-- > let request = initialRequest { method = "POST", requestBody = RequestBodyLBS $ encode requestObject }
-- >
-- > response <- httpLbs request
-- > liftIO . putStrLn $ "The status code was: " <> (show $ statusCode $ responseStatus response)
-- > liftIO . print $ responseBody response
module Effectful.HttpClient
( -- * Effect
HttpClient
, runHttpClient
, runHttpClientWith
, runHttpClientTls
, runHttpClientTlsWith
-- * Performing requests
, responseOpen
, responseClose
, withResponse
, httpLbs
, httpNoBody
-- * Re-exports
-- ** Request types and fields
, Request
, RequestBody (..)
, parseRequest
, parseRequest_
, parseUrlThrow
, requestFromURI
, requestFromURI_
, method
, requestBody
, requestHeaders
, redirectCount
, responseTimeout
, applyBasicAuth
, applyBearerAuth
, applyBasicProxyAuth
, setRequestCheckStatus
, urlEncodedBody
-- ** Response types and fields
, Response
, responseBody
, responseStatus
, responseHeaders
, responseCookieJar
-- ** Connection manager settings
, ManagerSettings
, defaultManagerSettings
, managerConnCount
, managerResponseTimeout
, managerIdleConnectionCount
, managerSetProxy
, managerSetInsecureProxy
, managerSetSecureProxy
-- ** Proxy
, Proxy (..)
, ProxyOverride
, proxyEnvironment
, proxyEnvironmentNamed
, noProxy
, useProxy
-- ** Cookies
, Cookie (..)
, CookieJar
, createCookieJar
, destroyCookieJar
-- ** Timeouts
, ResponseTimeout
, responseTimeoutDefault
, responseTimeoutMicro
, responseTimeoutNone
-- ** Exceptions
, HttpException (..)
, HttpExceptionContent (..)
)
where
import Data.ByteString.Lazy (LazyByteString)
import Effectful
import Effectful.Dispatch.Static
import Effectful.Exception (bracket)
import Network.HTTP.Client hiding
( closeManager
, httpLbs
, httpNoBody
, newManager
, responseClose
, responseOpen
, responseOpenHistory
, withManager
, withResponse
, withResponseHistory
)
import Network.HTTP.Client qualified as Client
import Network.HTTP.Client.TLS (newTlsManagerWith)
import Prelude
data HttpClient :: Effect
type instance DispatchOf HttpClient = 'Static 'WithSideEffects
newtype instance StaticRep HttpClient = HttpClient Manager
-- | Plain HTTP only.
runHttpClientWith :: (IOE :> es) => ManagerSettings -> Eff (HttpClient ': es) a -> Eff es a
runHttpClientWith settings eff = do
manager <- liftIO $ Client.newManager settings
evalStaticRep (HttpClient manager) eff
-- | Call 'runHttpClientWith' with 'defaultManagerSettings'.
runHttpClient :: (IOE :> es) => Eff (HttpClient ': es) a -> Eff es a
runHttpClient = runHttpClientWith defaultManagerSettings
-- | HTTP and HTTPS.
runHttpClientTlsWith :: (IOE :> es) => ManagerSettings -> Eff (HttpClient ': es) a -> Eff es a
runHttpClientTlsWith settings eff = do
manager <- liftIO $ newTlsManagerWith settings
evalStaticRep (HttpClient manager) eff
-- | Call 'runHttpClientTlsWith' with 'defaultManagerSettings'.
runHttpClientTls :: (IOE :> es) => Eff (HttpClient ': es) a -> Eff es a
runHttpClientTls = runHttpClientTlsWith defaultManagerSettings
-- | Internal escape hatch granting raw access to the underlying 'Manager'.
-- We do not export it: keeping the 'Manager' opaque is the whole point of this effect.
withManager :: (HttpClient :> es) => (Manager -> IO a) -> Eff es a
withManager f = do
HttpClient manager <- getStaticRep
unsafeEff_ $ f manager
-- | Lifted 'Client.responseOpen'.
responseOpen :: (HttpClient :> es) => Request -> Eff es (Response BodyReader)
responseOpen req = do
HttpClient manager <- getStaticRep
unsafeEff_ $ Client.responseOpen req manager
-- | Lifted 'Client.responseClose'.
responseClose :: (HttpClient :> es) => Response a -> Eff es ()
responseClose = unsafeEff_ . Client.responseClose
-- | Lifted 'Client.withResponse'.
withResponse :: (HttpClient :> es) => Request -> (Response BodyReader -> Eff es a) -> Eff es a
withResponse req = responseOpen req `bracket` responseClose
-- | Lifted 'Client.httpLbs'.
httpLbs :: (HttpClient :> es) => Request -> Eff es (Response LazyByteString)
httpLbs = withManager . Client.httpLbs
-- | Lifted 'Client.httpNoBody'.
httpNoBody :: (HttpClient :> es) => Request -> Eff es (Response ())
httpNoBody = withManager . Client.httpNoBody