{-# LANGUAGE Trustworthy, NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, FlexibleContexts, ConstraintKinds #-}
module Magicbane.HTTPClient (
module Magicbane.HTTPClient
, module X
) where
import RIO
import qualified RIO.Map as M
import qualified RIO.Set as S
import Control.Monad.Catch as X (MonadCatch)
import Control.Monad.Trans.Except as X (ExceptT (..), runExceptT)
import qualified Control.Monad.Trans.Except as MTE
import Control.Monad.IO.Unlift as X (MonadUnliftIO)
import UnliftIO.Exception (tryAny)
import Data.Aeson (ToJSON, encode)
import Data.Bifunctor
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L (ByteString, toStrict)
import Data.Conduit
import qualified Data.Conduit.Combinators as C
import Data.String.Conversions
import Data.Text (Text, pack)
import Network.URI as X
import Network.HTTP.Types
import Network.HTTP.Conduit as HC
import Network.HTTP.Client.Conduit as HCC
import Network.HTTP.Client.Internal (setUri)
import Network.HTTP.Client as X hiding (Proxy, path)
import Network.HTTP.Client.TLS (newTlsManager)
import Magicbane.Util (writeForm)
newtype ModHttpClient = ModHttpClient Manager
newHttpClient ∷ IO ModHttpClient
newHttpClient = ModHttpClient <$> newTlsManager
type MonadHTTP ψ μ = (HasHttpManager ψ, MonadReader ψ μ, MonadUnliftIO μ)
runHTTP ∷ ExceptT ε μ α → μ (Either ε α)
runHTTP = MTE.runExceptT
reqU ∷ (MonadHTTP ψ μ) ⇒ URI → ExceptT Text μ Request
reqU uri = ExceptT $ return $ bimap (pack.show) id $ setUri defaultRequest uri
reqS ∷ (MonadHTTP ψ μ, ConvertibleStrings σ String) ⇒ σ → ExceptT Text μ Request
reqS uri = ExceptT $ return $ bimap (pack.show) id $ parseUrlThrow $ cs uri
anyStatus ∷ (MonadHTTP ψ μ) ⇒ Request → ExceptT Text μ Request
anyStatus req = return $ setRequestIgnoreStatus req
postForm ∷ (MonadHTTP ψ μ) ⇒ [(Text, Text)] → Request → ExceptT Text μ Request
postForm form req = return
$ req { method = "POST"
, requestBody = RequestBodyBS $ writeForm form }
& applyHeaders
[ (hContentType, "application/x-www-form-urlencoded; charset=utf-8") ]
postJson ∷ (MonadHTTP ψ μ, ToJSON α) ⇒ α → Request → ExceptT Text μ Request
postJson body req = return
$ req { method = "POST"
, requestBody = RequestBodyBS . L.toStrict . encode $ body }
& applyHeaders
[ (hContentType, "application/json; charset=utf-8") ]
performWithFn ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ (ConduitM ι ByteString μ () → ConduitT () Void μ ρ) → Request → ExceptT Text μ (Response ρ)
performWithFn fn req = do
res ← lift $ tryAny $ HCC.withResponse req $ \res → do
body ← runConduit $ fn $ responseBody res
return res { responseBody = body }
ExceptT $ return $ bimap (pack.show) id res
performWithVoid ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → ExceptT Text μ (Response ())
performWithVoid = performWithFn (const $ return ())
performWithBytes ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → ExceptT Text μ (Response L.ByteString)
performWithBytes = performWithFn (.| C.sinkLazy)
applyHeaders ∷ RequestHeaders → Request → Request
applyHeaders headers req =
req { requestHeaders = updated }
where
updated = M.toList $ new `M.union` old
new = M.fromList headers
old = M.fromList $ requestHeaders req
removeHeaders ∷ [HeaderName] → Request → Request
removeHeaders headerNames req =
req { requestHeaders = updated }
where
updated = M.toList $ old `M.withoutKeys` keysToRemove
keysToRemove = S.fromList headerNames
old = M.fromList $ requestHeaders req