diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [1.0.0] - 2026-07-07 + +### Added + +- Initial release. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,287 @@ + EUROPEAN UNION PUBLIC LICENCE v. 1.2 + EUPL © the European Union 2007, 2016 + +This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined +below) which is provided under the terms of this Licence. Any use of the Work, +other than as authorised under this Licence is prohibited (to the extent such +use is covered by a right of the copyright holder of the Work). + +The Work is provided under the terms of this Licence when the Licensor (as +defined below) has placed the following notice immediately following the +copyright notice for the Work: + + Licensed under the EUPL + +or has expressed by any other means his willingness to license under the EUPL. + +1. Definitions + +In this Licence, the following terms have the following meaning: + +- ‘The Licence’: this Licence. + +- ‘The Original Work’: the work or software distributed or communicated by the + Licensor under this Licence, available as Source Code and also as Executable + Code as the case may be. + +- ‘Derivative Works’: the works or software that could be created by the + Licensee, based upon the Original Work or modifications thereof. This Licence + does not define the extent of modification or dependence on the Original Work + required in order to classify a work as a Derivative Work; this extent is + determined by copyright law applicable in the country mentioned in Article 15. + +- ‘The Work’: the Original Work or its Derivative Works. + +- ‘The Source Code’: the human-readable form of the Work which is the most + convenient for people to study and modify. + +- ‘The Executable Code’: any code which has generally been compiled and which is + meant to be interpreted by a computer as a program. + +- ‘The Licensor’: the natural or legal person that distributes or communicates + the Work under the Licence. + +- ‘Contributor(s)’: any natural or legal person who modifies the Work under the + Licence, or otherwise contributes to the creation of a Derivative Work. + +- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of + the Work under the terms of the Licence. + +- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending, + renting, distributing, communicating, transmitting, or otherwise making + available, online or offline, copies of the Work or providing access to its + essential functionalities at the disposal of any other natural or legal + person. + +2. Scope of the rights granted by the Licence + +The Licensor hereby grants You a worldwide, royalty-free, non-exclusive, +sublicensable licence to do the following, for the duration of copyright vested +in the Original Work: + +- use the Work in any circumstance and for all usage, +- reproduce the Work, +- modify the Work, and make Derivative Works based upon the Work, +- communicate to the public, including the right to make available or display + the Work or copies thereof to the public and perform publicly, as the case may + be, the Work, +- distribute the Work or copies thereof, +- lend and rent the Work or copies thereof, +- sublicense rights in the Work or copies thereof. + +Those rights can be exercised on any media, supports and formats, whether now +known or later invented, as far as the applicable law permits so. + +In the countries where moral rights apply, the Licensor waives his right to +exercise his moral right to the extent allowed by law in order to make effective +the licence of the economic rights here above listed. + +The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to +any patents held by the Licensor, to the extent necessary to make use of the +rights granted on the Work under this Licence. + +3. Communication of the Source Code + +The Licensor may provide the Work either in its Source Code form, or as +Executable Code. If the Work is provided as Executable Code, the Licensor +provides in addition a machine-readable copy of the Source Code of the Work +along with each copy of the Work that the Licensor distributes or indicates, in +a notice following the copyright notice attached to the Work, a repository where +the Source Code is easily and freely accessible for as long as the Licensor +continues to distribute or communicate the Work. + +4. Limitations on copyright + +Nothing in this Licence is intended to deprive the Licensee of the benefits from +any exception or limitation to the exclusive rights of the rights owners in the +Work, of the exhaustion of those rights or of other applicable limitations +thereto. + +5. Obligations of the Licensee + +The grant of the rights mentioned above is subject to some restrictions and +obligations imposed on the Licensee. Those obligations are the following: + +Attribution right: The Licensee shall keep intact all copyright, patent or +trademarks notices and all notices that refer to the Licence and to the +disclaimer of warranties. The Licensee must include a copy of such notices and a +copy of the Licence with every copy of the Work he/she distributes or +communicates. The Licensee must cause any Derivative Work to carry prominent +notices stating that the Work has been modified and the date of modification. + +Copyleft clause: If the Licensee distributes or communicates copies of the +Original Works or Derivative Works, this Distribution or Communication will be +done under the terms of this Licence or of a later version of this Licence +unless the Original Work is expressly distributed only under this version of the +Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee +(becoming Licensor) cannot offer or impose any additional terms or conditions on +the Work or Derivative Work that alter or restrict the terms of the Licence. + +Compatibility clause: If the Licensee Distributes or Communicates Derivative +Works or copies thereof based upon both the Work and another work licensed under +a Compatible Licence, this Distribution or Communication can be done under the +terms of this Compatible Licence. For the sake of this clause, ‘Compatible +Licence’ refers to the licences listed in the appendix attached to this Licence. +Should the Licensee's obligations under the Compatible Licence conflict with +his/her obligations under this Licence, the obligations of the Compatible +Licence shall prevail. + +Provision of Source Code: When distributing or communicating copies of the Work, +the Licensee will provide a machine-readable copy of the Source Code or indicate +a repository where this Source will be easily and freely available for as long +as the Licensee continues to distribute or communicate the Work. + +Legal Protection: This Licence does not grant permission to use the trade names, +trademarks, service marks, or names of the Licensor, except as required for +reasonable and customary use in describing the origin of the Work and +reproducing the content of the copyright notice. + +6. Chain of Authorship + +The original Licensor warrants that the copyright in the Original Work granted +hereunder is owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each Contributor warrants that the copyright in the modifications he/she brings +to the Work are owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each time You accept the Licence, the original Licensor and subsequent +Contributors grant You a licence to their contributions to the Work, under the +terms of this Licence. + +7. Disclaimer of Warranty + +The Work is a work in progress, which is continuously improved by numerous +Contributors. It is not a finished work and may therefore contain defects or +‘bugs’ inherent to this type of development. + +For the above reason, the Work is provided under the Licence on an ‘as is’ basis +and without warranties of any kind concerning the Work, including without +limitation merchantability, fitness for a particular purpose, absence of defects +or errors, accuracy, non-infringement of intellectual property rights other than +copyright as stated in Article 6 of this Licence. + +This disclaimer of warranty is an essential part of the Licence and a condition +for the grant of any rights to the Work. + +8. Disclaimer of Liability + +Except in the cases of wilful misconduct or damages directly caused to natural +persons, the Licensor will in no event be liable for any direct or indirect, +material or moral, damages of any kind, arising out of the Licence or of the use +of the Work, including without limitation, damages for loss of goodwill, work +stoppage, computer failure or malfunction, loss of data or any commercial +damage, even if the Licensor has been advised of the possibility of such damage. +However, the Licensor will be liable under statutory product liability laws as +far such laws apply to the Work. + +9. Additional agreements + +While distributing the Work, You may choose to conclude an additional agreement, +defining obligations or services consistent with this Licence. However, if +accepting obligations, You may act only on your own behalf and on your sole +responsibility, not on behalf of the original Licensor or any other Contributor, +and only if You agree to indemnify, defend, and hold each Contributor harmless +for any liability incurred by, or claims asserted against such Contributor by +the fact You have accepted any warranty or additional liability. + +10. Acceptance of the Licence + +The provisions of this Licence can be accepted by clicking on an icon ‘I agree’ +placed under the bottom of a window displaying the text of this Licence or by +affirming consent in any other similar way, in accordance with the rules of +applicable law. Clicking on that icon indicates your clear and irrevocable +acceptance of this Licence and all of its terms and conditions. + +Similarly, you irrevocably accept this Licence and all of its terms and +conditions by exercising any rights granted to You by Article 2 of this Licence, +such as the use of the Work, the creation by You of a Derivative Work or the +Distribution or Communication by You of the Work or copies thereof. + +11. Information to the public + +In case of any Distribution or Communication of the Work by means of electronic +communication by You (for example, by offering to download the Work from a +remote location) the distribution channel or media (for example, a website) must +at least provide to the public the information requested by the applicable law +regarding the Licensor, the Licence and the way it may be accessible, concluded, +stored and reproduced by the Licensee. + +12. Termination of the Licence + +The Licence and the rights granted hereunder will terminate automatically upon +any breach by the Licensee of the terms of the Licence. + +Such a termination will not terminate the licences of any person who has +received the Work from the Licensee under the Licence, provided such persons +remain in full compliance with the Licence. + +13. Miscellaneous + +Without prejudice of Article 9 above, the Licence represents the complete +agreement between the Parties as to the Work. + +If any provision of the Licence is invalid or unenforceable under applicable +law, this will not affect the validity or enforceability of the Licence as a +whole. Such provision will be construed or reformed so as necessary to make it +valid and enforceable. + +The European Commission may publish other linguistic versions or new versions of +this Licence or updated versions of the Appendix, so far this is required and +reasonable, without reducing the scope of the rights granted by the Licence. New +versions of the Licence will be published with a unique version number. + +All linguistic versions of this Licence, approved by the European Commission, +have identical value. Parties can take advantage of the linguistic version of +their choice. + +14. Jurisdiction + +Without prejudice to specific agreement between parties, + +- any litigation resulting from the interpretation of this License, arising + between the European Union institutions, bodies, offices or agencies, as a + Licensor, and any Licensee, will be subject to the jurisdiction of the Court + of Justice of the European Union, as laid down in article 272 of the Treaty on + the Functioning of the European Union, + +- any litigation arising between other parties and resulting from the + interpretation of this License, will be subject to the exclusive jurisdiction + of the competent court where the Licensor resides or conducts its primary + business. + +15. Applicable Law + +Without prejudice to specific agreement between parties, + +- this Licence shall be governed by the law of the European Union Member State + where the Licensor has his seat, resides or has his registered office, + +- this licence shall be governed by Belgian law if the Licensor has no seat, + residence or registered office inside a European Union Member State. + +Appendix + +‘Compatible Licences’ according to Article 5 EUPL are: + +- GNU General Public License (GPL) v. 2, v. 3 +- GNU Affero General Public License (AGPL) v. 3 +- Open Software License (OSL) v. 2.1, v. 3.0 +- Eclipse Public License (EPL) v. 1.0 +- CeCILL v. 2.0, v. 2.1 +- Mozilla Public Licence (MPL) v. 2 +- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3 +- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for + works other than software +- European Union Public Licence (EUPL) v. 1.1, v. 1.2 +- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong + Reciprocity (LiLiQ-R+). + +The European Commission may update this Appendix to later versions of the above +licences without producing a new version of the EUPL, as long as they provide +the rights granted in Article 2 of this Licence and protect the covered Source +Code from exclusive appropriation. + +All other changes or additions to this Appendix require the production of a new +EUPL version. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/http2-client-effectful.cabal b/http2-client-effectful.cabal new file mode 100644 --- /dev/null +++ b/http2-client-effectful.cabal @@ -0,0 +1,60 @@ +cabal-version: 3.0 +name: http2-client-effectful +version: 1.0.0 +synopsis: Effectful bindings for the http2-client library +description: + Adaptation of the @@ library for the @@ ecosystem. + +homepage: https://digital-autonomy.institute +license: EUPL-1.2 +license-file: LICENCE +author: IDA +maintainer: IDA +bug-reports: https://issues.digital-autonomy.institute +category: Web +build-type: Simple +extra-source-files: + CHANGELOG.md + +common common + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-unsafe + -Wno-missing-safe-haskell-mode + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-all-missed-specialisations + -Wno-missing-role-annotations + + default-extensions: + BlockArguments + DataKinds + ExplicitNamespaces + FlexibleContexts + ImportQualifiedPost + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + +library + import: common + hs-source-dirs: src + build-depends: + base >=4.10 && <5, + bytestring >=0.12 && <0.13, + effectful >=2.6 && <2.7, + http-types >=0.12 && <0.13, + http2 >=5.3 && <5.4, + http2-client >=0.10 && <0.11, + mtl >=2.3 && <2.4, + + exposed-modules: + Effectful.Http2Client diff --git a/src/Effectful/Http2Client.hs b/src/Effectful/Http2Client.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Http2Client.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Effectful.Http2Client +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- Effectful bindings for the . +-- +-- @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