{-# LANGUAGE PackageImports #-}
{-# LANGUAGE Trustworthy #-}
-- |
-- Module : Effectful.Http2Client
-- Copyright : (c) 2026 Institute for Digital Autonomy
-- License : EUPL-1.2
-- Maintainer : IDA
--
-- Effectful bindings for the <http://hackage.haskell.org/package/http2-client http2-client library>.
--
-- @http2-client@ exposes streams, flow control, and push promises as
-- first-class values, working in its own 'ClientIO' monad.
-- This module lifts that API into 'Eff': 'runHttp2Client' handles thread-linking
-- and client teardown, so the rest of the operations here can be used
-- directly in your effect stack.
--
-- = Example Usage
--
-- === Opening a connection and running a client
--
-- > import Effectful
-- > import Effectful.Error.Static (runErrorNoCallStack)
-- > import Effectful.Http2Client
-- >
-- > main :: IO ()
-- > main = do
-- > result <- runEff . runErrorNoCallStack @ClientError $ do
-- > conn <- newHttp2FrameConnection "http2.example.com" 443 (Just tlsClientParams)
-- > runHttp2Client conn 4096 4096 [] defaultGoAwayHandler ignoreFallbackHandler $ do
-- > -- ... open streams here, see below ...
-- > pure ()
-- > print result
--
-- === A simple GET request
--
-- > getRoot :: (Http2Client :> es, Effectful.Error.Static.Error ClientError :> es) => Eff es (Either TooMuchConcurrency StreamResult)
-- > getRoot =
-- > withHttp2Stream $ \stream ->
-- > StreamDefinition
-- > { _initStream =
-- > _headers
-- > stream
-- > [ (":method", "GET")
-- > , (":scheme", "https")
-- > , (":authority", "http2.example.com")
-- > , (":path", "/")
-- > ]
-- > id
-- > , _handleStream = \incomingFlow _outgoingFlow ->
-- > waitStream stream incomingFlow ignorePushPromises
-- > }
-- > where
-- > ignorePushPromises _streamId _pushedStream _headers' _ifc _ofc = pure ()
--
-- === Uploading a request body
--
-- > postBody :: (Http2Client :> es, Effectful.Error.Static.Error ClientError :> es) => ByteString -> Eff es (Either TooMuchConcurrency StreamResult)
-- > postBody body =
-- > withHttp2Stream $ \stream ->
-- > StreamDefinition
-- > { _initStream =
-- > _headers
-- > stream
-- > [ (":method", "POST")
-- > , (":scheme", "https")
-- > , (":authority", "http2.example.com")
-- > , (":path", "/upload")
-- > ]
-- > id
-- > , _handleStream = \incomingFlow outgoingFlow -> do
-- > connFlow <- _outgoingFlowControl
-- > upload body id connFlow stream outgoingFlow
-- > waitStream stream incomingFlow ignorePushPromises
-- > }
-- > where
-- > ignorePushPromises _streamId _pushedStream _headers' _ifc _ofc = pure ()
module Effectful.Http2Client
( -- * Effect
Http2Client
, runHttp2Client
-- * Performing requests
, withHttp2Stream
, upload
, waitStream
, linkAsyncs
, _incomingFlowControl
, _outgoingFlowControl
, newHttp2FrameConnection
, runClientIO
-- ** Streams
, Http2Stream (..)
, StreamDefinition (..)
, StreamStarter
-- ** Flow control
, IncomingFlowControl (..)
, OutgoingFlowControl (..)
-- ** Handlers
, GoAwayHandler
, FallBackFrameHandler
, PushPromiseHandler
, defaultGoAwayHandler
, ignoreFallbackHandler
-- * Re-exports
-- ** Connections
, Http2FrameConnection
, HostName
, PortNumber
, SettingsList
, SettingsKey (..)
, SettingsValue
-- ** Streams
, StreamThread
, StreamEvent (..)
, StreamResponse
, StreamResult
, TooMuchConcurrency (..)
, RequestHeaders
, FlagSetter
, fromStreamResult
-- ** Errors
, ClientError (..)
, RemoteSentGoAwayFrame (..)
)
where
import Control.Monad ((<=<))
import Control.Monad.Except (ExceptT (..))
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Effectful
import Effectful.Dispatch.Static
import Effectful.Error.Static (Error, runErrorNoCallStack, throwError)
import Effectful.Exception (finally)
import Network.HTTP.Types (Header, RequestHeaders)
import Network.HTTP2.Client.Helpers (StreamResponse, StreamResult, fromStreamResult)
import Network.HTTP2.Frame
( ErrorCode
, FrameFlags
, FrameHeader
, FramePayload
, Priority
, SettingsKey (..)
, SettingsList
, SettingsValue
, StreamId
, WindowSize
, flags
, payloadLength
, testEndStream
)
import "http2-client" Network.HTTP2.Client
( ClientError (..)
, ClientIO
, FlagSetter
, HostName
, Http2FrameConnection
, PortNumber
, RemoteSentGoAwayFrame (..)
, StreamEvent (..)
, StreamThread
, TooMuchConcurrency (..)
)
import "http2-client" Network.HTTP2.Client qualified as Client
import Prelude
data Http2Client :: Effect
type instance DispatchOf Http2Client = 'Static 'WithSideEffects
newtype instance StaticRep Http2Client = Http2Client Client.Http2Client
runHttp2Client
:: forall es a
. (IOE :> es, Error ClientError :> es)
=> Http2FrameConnection
-> Int
-- ^ The buffersize for the Network.HPACK encoder.
-> Int
-- ^ The buffersize for the Network.HPACK decoder.
-> SettingsList
-> GoAwayHandler
-> FallBackFrameHandler
-> Eff (Http2Client ': es) a
-> Eff es a
runHttp2Client frameConn encoderBufSize decoderBufSize initSettings goAwayHandler fallbackHandler eff =
either throwError pure =<< unsafeConcUnliftIO Ephemeral (Limited 1) \unlift ->
Client.runClientIO do
let unliftClientIO :: Eff es b -> ClientIO b
unliftClientIO =
ExceptT
. unlift
. runErrorNoCallStack @ClientError
. inject
client <-
Client.newHttp2Client
frameConn
encoderBufSize
decoderBufSize
initSettings
(unliftClientIO . goAwayHandler)
(unliftClientIO . fallbackHandler)
ExceptT . unlift . runErrorNoCallStack @ClientError . inject $
evalStaticRep (Http2Client client) (linkAsyncs >> eff)
`finally` (runClientIO . Client._close) client
type GoAwayHandler = forall es. (Error ClientError :> es) => RemoteSentGoAwayFrame -> Eff es ()
-- | Lifted 'Client.defaultGoAwayHandler'.
defaultGoAwayHandler :: GoAwayHandler
defaultGoAwayHandler = unsafeRunClientIO . Client.defaultGoAwayHandler
type FallBackFrameHandler =
forall es
. (Error ClientError :> es)
=> (FrameHeader, FramePayload)
-> Eff es ()
-- | Lifted 'Client.ignoreFallbackHandler'.
ignoreFallbackHandler :: FallBackFrameHandler
ignoreFallbackHandler = unsafeRunClientIO . Client.ignoreFallbackHandler
unsafeRunClientIO :: (Error ClientError :> es) => ClientIO a -> Eff es a
unsafeRunClientIO action = do
result <- unsafeEff_ $ Client.runClientIO action
case result of
Left err -> throwError err
Right a -> pure a
-- | Lifted 'Client.runClientIO'.
-- Escape hatch for 'ClientIO' actions that are not lifted by this library.
runClientIO
:: (IOE :> es, Error ClientError :> es)
=> ClientIO a
-> Eff es a
runClientIO = either throwError pure <=< liftIO . Client.runClientIO
-- | Lifted 'Client.newHttp2FrameConnection'.
newHttp2FrameConnection
:: (Error ClientError :> es)
=> HostName
-> PortNumber
-> Maybe Client.ClientParams
-> Eff es Http2FrameConnection
newHttp2FrameConnection host port = unsafeRunClientIO . Client.newHttp2FrameConnection host port
-- | Lifted 'Client.linkAsyncs'.
linkAsyncs :: (Http2Client :> es, Error ClientError :> es) => Eff es ()
linkAsyncs = do
Http2Client client <- getStaticRep
unsafeRunClientIO $ Client.linkAsyncs client
-- | Lifted 'Client.IncomingFlowControl'.
data IncomingFlowControl es = IncomingFlowControl
{ _addCredit :: WindowSize -> Eff es ()
, _consumeCredit :: WindowSize -> Eff es Int
, _updateWindow :: Eff es Bool
}
liftIncomingFlowControl
:: (Error ClientError :> es)
=> Client.IncomingFlowControl
-> IncomingFlowControl es
liftIncomingFlowControl Client.IncomingFlowControl{..} =
IncomingFlowControl
{ _addCredit = unsafeEff_ . _addCredit
, _consumeCredit = unsafeEff_ . _consumeCredit
, _updateWindow = unsafeRunClientIO _updateWindow
}
-- | Lifted 'Client.OutgoingFlowControl'.
data OutgoingFlowControl es = OutgoingFlowControl
{ _receiveCredit :: WindowSize -> Eff es ()
, _withdrawCredit :: WindowSize -> Eff es WindowSize
}
liftOutgoingFlowControl
:: (Error ClientError :> es)
=> Client.OutgoingFlowControl
-> OutgoingFlowControl es
liftOutgoingFlowControl Client.OutgoingFlowControl{..} =
OutgoingFlowControl
{ _receiveCredit = unsafeEff_ . _receiveCredit
, _withdrawCredit = unsafeRunClientIO . _withdrawCredit
}
-- | Lifted 'Client.StreamDefinition'.
data StreamDefinition es a = StreamDefinition
{ _initStream :: Eff es StreamThread
, _handleStream :: IncomingFlowControl es -> OutgoingFlowControl es -> Eff es a
}
unliftStreamDefinition
:: (Error ClientError :> es)
=> (forall r. Eff es r -> ClientIO r)
-> StreamDefinition es a
-> Client.StreamDefinition a
unliftStreamDefinition unliftClientIO StreamDefinition{..} =
Client.StreamDefinition
{ _initStream = unliftClientIO _initStream
, _handleStream = \i o ->
unliftClientIO $
_handleStream (liftIncomingFlowControl i) (liftOutgoingFlowControl o)
}
-- | Lifted 'Client.Http2Stream'.
data Http2Stream es = Http2Stream
{ _headers
:: [Header]
-> (FrameFlags -> FrameFlags)
-> Eff es StreamThread
, _prio :: Priority -> Eff es ()
, _rst :: ErrorCode -> Eff es ()
, _waitEvent :: Eff es StreamEvent
, _sendData :: (FrameFlags -> FrameFlags) -> ByteString -> Eff es ()
, _sendDataChunk :: (FrameFlags -> FrameFlags) -> ByteString -> Eff es ()
, _handlePushPromise :: StreamId -> [Header] -> PushPromiseHandler es -> Eff es ()
}
liftHttp2Stream
:: forall es
. (Error ClientError :> es)
=> Client.Http2Client
-> Client.Http2Stream
-> Http2Stream es
liftHttp2Stream client stream =
Http2Stream
{ _headers = \hdrs flagMod -> unsafeRunClientIO (Client._headers stream hdrs flagMod)
, _prio = unsafeRunClientIO . Client._prio stream
, _rst = unsafeRunClientIO . Client._rst stream
, _waitEvent = unsafeRunClientIO (Client._waitEvent stream)
, _sendData = \flagMod dat -> unsafeRunClientIO (Client.sendData client stream flagMod dat)
, _sendDataChunk = \flagMod dat -> unsafeRunClientIO (Client._sendDataChunk stream flagMod dat)
, _handlePushPromise = \sid hdrs handler ->
either throwError pure
=<< unsafeConcUnliftIO Ephemeral (Limited 1) \unlift -> Client.runClientIO do
let unliftClientIO :: Eff es b -> ClientIO b
unliftClientIO = ExceptT . unlift . runErrorNoCallStack @ClientError . inject
Client._handlePushPromise
stream
sid
hdrs
(unliftPushPromiseHandler client unliftClientIO handler)
}
-- | Handler invoked upon receiving an HTTP\/2 PUSH_PROMISE from the server,
-- lifted into 'Eff'. Mirrors @http2-client@'s 'Client.PushPromiseHandler' but with the
-- stream and flow-control objects expressed in terms of 'Eff'.
type PushPromiseHandler es =
StreamId
-> Http2Stream es
-> [Header]
-> IncomingFlowControl es
-> OutgoingFlowControl es
-> Eff es ()
unliftPushPromiseHandler
:: forall es
. (Error ClientError :> es)
=> Client.Http2Client
-> (forall r. Eff es r -> ClientIO r)
-> PushPromiseHandler es
-> Client.PushPromiseHandler
unliftPushPromiseHandler client unliftClientIO ppHandler sid stream hdrs ifc ofc =
unliftClientIO $
ppHandler
sid
(liftHttp2Stream client stream)
hdrs
(liftIncomingFlowControl ifc)
(liftOutgoingFlowControl ofc)
type StreamStarter es a =
(Http2Stream es -> StreamDefinition es a)
-> Eff es (Either TooMuchConcurrency a)
-- | Lifted 'Client.withHttp2Stream'.
withHttp2Stream
:: forall es a
. (Http2Client :> es, Error ClientError :> es)
=> StreamStarter es a
withHttp2Stream f = do
Http2Client client <- getStaticRep
either throwError pure
=<< unsafeConcUnliftIO Ephemeral (Limited 1) \unlift -> Client.runClientIO do
let unliftClientIO :: Eff es b -> ClientIO b
unliftClientIO = ExceptT . unlift . runErrorNoCallStack @ClientError . inject
Client._startStream client $ unliftStreamDefinition unliftClientIO . f . liftHttp2Stream client
-- | Lifted 'Client.upload'.
upload
:: forall es
. ByteString
-> FlagSetter
-> OutgoingFlowControl es
-- ^ The connection-wide outgoing flow control.
-> Http2Stream es
-> OutgoingFlowControl es
-- ^ The stream-wide outgoing flow control.
-> Eff es ()
upload dat flagSetter connFlow stream streamFlow = go dat
where
go :: ByteString -> Eff es ()
go d = do
let wanted = ByteString.length d
gotStream <- _withdrawCredit streamFlow wanted
got <- _withdrawCredit connFlow gotStream
_receiveCredit streamFlow $ gotStream - got
if got == wanted
then _sendData stream flagSetter d
else do
_sendData stream id $ ByteString.take got d
go $ ByteString.drop got d
-- | Lifted 'Client.waitStream'.
waitStream
:: forall es
. (Http2Client :> es, Error ClientError :> es)
=> Http2Stream es
-> IncomingFlowControl es
-> PushPromiseHandler es
-> Eff es StreamResult
waitStream stream streamFlow ppHandler = do
connFlow <- _incomingFlowControl
let
waitDataFrames xs = do
ev <- _waitEvent stream
case ev of
StreamDataEvent fh x
| testEndStream (flags fh) ->
pure (Right x : xs, Nothing)
| otherwise -> do
let size = payloadLength fh
_ <- _consumeCredit streamFlow size
_addCredit streamFlow size
_ <- _updateWindow streamFlow
_ <- _updateWindow connFlow
waitDataFrames (Right x : xs)
StreamPushPromiseEvent _ ppSid ppHdrs -> do
_handlePushPromise stream ppSid ppHdrs ppHandler
waitDataFrames xs
StreamHeadersEvent _ hdrs ->
pure (xs, Just hdrs)
_ ->
error $ "expecting StreamDataEvent but got " <> show ev
loop = do
ev <- _waitEvent stream
case ev of
StreamHeadersEvent fH hdrs
| testEndStream (flags fH) ->
pure (Right hdrs, [], Nothing)
| otherwise -> do
(dfrms, trls) <- waitDataFrames []
pure (Right hdrs, reverse dfrms, trls)
StreamPushPromiseEvent _ ppSid ppHdrs -> do
_handlePushPromise stream ppSid ppHdrs ppHandler
loop
_ ->
error $ "expecting StreamHeadersEvent but got " <> show ev
loop
-- | Lifted 'Client._incomingFlowControl'.
_incomingFlowControl
:: (Http2Client :> es, Error ClientError :> es)
=> Eff es (IncomingFlowControl es)
_incomingFlowControl = do
Http2Client client <- getStaticRep
pure . liftIncomingFlowControl . Client._incomingFlowControl $ client
-- | Lifted 'Client._outgoingFlowControl'.
_outgoingFlowControl
:: (Http2Client :> es, Error ClientError :> es)
=> Eff es (OutgoingFlowControl es)
_outgoingFlowControl = do
Http2Client client <- getStaticRep
pure . liftOutgoingFlowControl . Client._outgoingFlowControl $ client