{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Client.Overrides (
withHttpClientOverrides
, withHttpClientOverridesThrow
, withHttpClientOverridesFile
, httpClientOverrides
, parseConfigFile
, ConfigFile(..)
, Config(..)
, LogOptions(..)
, LogFormat(..)
, RequestOverride(..)
, URL(..)
) where
import Data.Either (either)
import Data.List (find)
import GHC.Stack (HasCallStack)
import System.Environment (lookupEnv)
import Data.Yaml (ParseException, decodeFileEither, prettyPrintParseException)
import Network.HTTP.Client (ManagerSettings, Response, Request)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.Overrides.Internal.Logger
import Network.HTTP.Client.Overrides.Internal.RequestOverrides
import Network.HTTP.Client.Overrides.Internal.Types
withHttpClientOverrides :: HasCallStack => ManagerSettings -> IO (Either ParseException ManagerSettings)
withHttpClientOverrides manager = do
filepath <- lookupEnv "HTTP_CLIENT_OVERRIDES"
case filepath of
Nothing ->
return $ return manager
Just f -> do
configFile <- parseConfigFile f
return $ fmap (\x -> withHttpClientOverridesFile x manager) configFile
withHttpClientOverridesThrow :: HasCallStack => ManagerSettings -> IO ManagerSettings
withHttpClientOverridesThrow manager = do
result <- withHttpClientOverrides manager
return . either parseError id $ result
where
parseError e = error $ errorMsg ++ prettyPrintParseException e
errorMsg = "Failed to parse HTTP client overrides config: "
parseConfigFile :: FilePath -> IO (Either ParseException ConfigFile)
parseConfigFile filepath = decodeFileEither filepath
withHttpClientOverridesFile :: ConfigFile -> ManagerSettings -> ManagerSettings
withHttpClientOverridesFile configFile = case configFile of
V1 config -> httpClientOverrides config
httpClientOverrides :: Config -> ManagerSettings -> ManagerSettings
httpClientOverrides config manager = manager
{ HTTP.managerModifyRequest = modifyRequest config
, HTTP.managerModifyResponse = modifyResponse config
}
modifyRequest :: Config -> Request -> IO Request
modifyRequest config r = do
r' <- maybe (return r) overriddenRequest $ matchRequest config r
logRequest config r'
return r'
where
overriddenRequest requestOverride = do
let r' = overrideRequest r requestOverride
logRequestOverride config requestOverride r r'
return r'
matchRequest :: Config -> Request -> Maybe RequestOverride
matchRequest config request =
find (\x -> request `matches` match x) $ requestOverrides config
modifyResponse :: Config -> Response body -> IO (Response body)
modifyResponse config r = do
logResponse config r
return r