diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -54,10 +54,12 @@ ### Help and examples -We currently provide a command-line example client: `http2-client-exe` which I -use as a test client and you could use to test various flow-control parameters. -Read `app/Main.hs` and `src/Network/HTTP2/Client/Helpers.hs` to look at how a -user application is implemented. +Please see some literate Haskell documents in the `examples/` directory. For +a more involved usage, we currently provide a command-line example client: +`http2-client-exe` which I use as a test client and you could use to test +various flow-control parameters. Read `app/Main.hs` and +`src/Network/HTTP2/Client/Helpers.hs` to look at how a user application is +implemented. The Haddocks should have plenty implementation details, so please have a look. Otherwise, you can ask help by creating an Issue on the bug-tracker. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -22,6 +22,13 @@ type Path = ByteString type Verb = ByteString +data PostData = PostBytestring !ByteString | PostFileContent FilePath + deriving Show + +postDataForString :: String -> PostData +postDataForString ('@':filepath) = PostFileContent filepath +postDataForString content = PostBytestring (ByteString.pack content) + data ServerPushSwitch = PushEnabled | PushDisabled deriving Show @@ -31,6 +38,7 @@ , _verb :: !Verb , _path :: !Path , _extraHeaders :: ![(ByteString, ByteString)] + , _postData :: !(Maybe PostData) , _interPingDelay :: !Int , _pingTimeout :: !Int , _interFlowControlUpdates :: !Int @@ -56,6 +64,7 @@ <*> verb <*> path <*> extraHeaders + <*> postData <*> milliseconds "inter-ping-delay-ms" 0 <*> milliseconds "ping-timeout-ms" 5000 <*> milliseconds "inter-flow-control-updates-ms" 1000 @@ -81,6 +90,7 @@ port = option auto (long "port" <> value 443) verb = bstrOption (long "verb" <> value "GET") extraHeaders = many (fmap keyval $ bstrOption (short 'H')) + postData = optional (fmap postDataForString (strOption (short 'd'))) concurrency = option auto (long "max-concurrency" <> value 100) allowPush = flag PushEnabled PushDisabled (long "disable-server-push") frameBytes = option auto (long "max-frame-size" <> value 1048576) @@ -105,6 +115,21 @@ client QueryArgs{..} = do hSetBuffering stdout LineBuffering + -- If we need to post data then we prepare an upload function. + -- Otherwise the function does nothing but we tell the server that we are + -- finished with the stream after HTTP headers. + -- + -- Note that this implementation reads the body from files and into memory + -- (better for testing concurrency, worse for large uploads). + (headersFlags, dataPostFunction) <- case _postData of + (Just (PostBytestring dataPayload)) -> + return $ (id, upload dataPayload) + (Just (PostFileContent filepath)) -> do + dataPayload <- ByteString.readFile filepath + return $ (id, upload dataPayload) + Nothing -> + return $ (HTTP2.setEndStream, \_ _ _ _ -> return ()) + let headersPairs = [ (":method", _verb) , (":scheme", "https") , (":path", _path) @@ -139,12 +164,16 @@ let go 0 idx = timePrint $ "done worker: " <> show idx go n idx = do - _ <- (_startStream conn $ \stream -> - let initStream = _headers stream headersPairs (HTTP2.setEndStream) - handler streamFlowControl _ = do + _ <- (withHttp2Stream conn $ \stream -> + let initStream = headers stream headersPairs headersFlags + handler streamINFlowControl streamOUTFlowControl = do _ <- async $ onPushPromise stream ppHandler timePrint $ "stream started " <> show (idx, n) - waitStream stream streamFlowControl >>= timePrint . fromStreamResult + _ <- async $ dataPostFunction conn + (_outgoingFlowControl conn) + stream + streamOUTFlowControl + waitStream stream streamINFlowControl >>= timePrint . fromStreamResult timePrint $ "stream ended " <> show (idx, n) in StreamDefinition initStream handler) go (n - 1) idx diff --git a/http2-client.cabal b/http2-client.cabal --- a/http2-client.cabal +++ b/http2-client.cabal @@ -1,5 +1,5 @@ name: http2-client -version: 0.2.0.1 +version: 0.2.0.2 synopsis: A native HTTP2 client library. description: Please read the README.md at the homepage. homepage: https://github.com/lucasdicioccio/http2-client diff --git a/src/Network/HTTP2/Client.hs b/src/Network/HTTP2/Client.hs --- a/src/Network/HTTP2/Client.hs +++ b/src/Network/HTTP2/Client.hs @@ -2,10 +2,18 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +-- | This module defines a set of low-level primitives for starting an HTTP2 +-- session and interacting with a server. +-- +-- For higher-level primitives, please refer to Network.HTTP2.Client.Helpers . module Network.HTTP2.Client ( - -- * Creating a client - Http2Client(..) - , newHttp2Client + -- * Basics + newHttp2Client + , withHttp2Stream + , headers + , sendData + -- * Starting streams + , Http2Client(..) , PushPromiseHandler -- * Starting streams , StreamDefinition(..) @@ -13,12 +21,12 @@ , TooMuchConcurrency(..) , StreamThread , Http2Stream(..) - -- * Sending data for POSTs. - , sendData -- * Flow control , IncomingFlowControl(..) , OutgoingFlowControl(..) -- * Misc. + , FlagSetter + , wrapFrameClient , _gtfo -- * Convenience re-exports , module Network.HTTP2.Client.FrameConnection @@ -46,7 +54,7 @@ import Network.HTTP2.Client.FrameConnection -- | Offers credit-based flow-control. --- +-- -- Any mutable changes are atomic and hence work as intended in a multithreaded -- setup. -- @@ -146,7 +154,7 @@ -- received. Hence we recommend wrapping this IO in an Async (e.g., with -- @race (threadDelay timeout)@.) , _goaway :: ErrorCodeId -> ByteString -> IO () - -- ^ Sends a GOAWAY. + -- ^ Sends a GOAWAY. , _startStream :: forall a. StreamStarter a -- ^ Spawns new streams. See 'StreamStarter'. , _incomingFlowControl :: IncomingFlowControl @@ -243,9 +251,63 @@ -- ^ Initial SETTINGS that are sent as first frame. -> IO Http2Client newHttp2Client host port encoderBufSize decoderBufSize tlsParams initSettings = do - -- network connection conn <- newHttp2FrameConnection host port tlsParams + wrapFrameClient conn encoderBufSize decoderBufSize initSettings +-- | Starts a new stream (i.e., one HTTP request + server-pushes). +-- +-- You will typically call the returned 'StreamStarter' immediately to define +-- what you want to do with the Http2Stream. +-- +-- @ _ <- (withHttp2Stream myClient $ \stream -> StreamDefinition _ _) @ +-- +-- Please refer to 'StreamStarter' and 'StreamDefinition' for more. +withHttp2Stream :: Http2Client -> StreamStarter a +withHttp2Stream = _startStream + +-- | Type synonym for functions that modify flags. +-- +-- Typical FlagSetter for library users are HTTP2.setEndHeader when sending +-- headers HTTP2.setEndStream to signal that there the client is not willing to +-- send more data. +-- +-- We might use Endo in the future. +type FlagSetter = FrameFlags -> FrameFlags + +-- | Sends the HTTP2+HTTP headers of your chosing. +-- +-- You must add HTTP2 pseudo-headers first, followed by your typical HTTP +-- headers. This function makes no verification of this +-- ordering/exhaustinevess. +-- +-- HTTP2 pseudo-headers replace the HTTP verb + parsed url as follows: +-- ":method" such as "GET", +-- ":scheme" such as "https", +-- ":path" such as "/blog/post/1234?foo=bar", +-- ":authority" such as "haskell.org" +-- +-- Note that we currently enforce the 'HTTP2.setEndHeader' but this design +-- choice may change in the future. Hence, we recommend you use +-- 'HTTP2.setEndHeader' as well. +headers :: Http2Stream -> HeaderList -> FlagSetter -> IO StreamThread +headers = _headers + +-- | Prepares a client around a frame connection. +-- +-- This is mostly useful if you want to muck around the Http2FrameConnection +-- (e.g., for tracing frames) as well as for unit testing purposes. If you want +-- to create a new connection you should likely use 'newHttp2Client' instead. +wrapFrameClient + :: Http2FrameConnection + -- ^ A frame connection. + -> Int + -- ^ The buffersize for the Network.HPACK encoder. + -> Int + -- ^ The buffersize for the Network.HPACK decoder. + -> SettingsList + -- ^ Initial SETTINGS that are sent as first frame. + -> IO Http2Client +wrapFrameClient conn encoderBufSize decoderBufSize initSettings = do -- prepare hpack contexts hpackEncoder <- do let strategy = (HPACK.defaultEncodeStrategy { HPACK.useHuffman = True }) @@ -362,7 +424,7 @@ -- Register interest in frames. frames <- dupChan serverFrames credits <- dupChan serverFrames - headers <- dupChan serverHeaders + headersFrames <- dupChan serverHeaders pushPromises <- dupChan serverPushPromises -- Builds a flow-control context. @@ -373,7 +435,7 @@ let _headers headersList flags = do splitter <- settingsPayloadSplitter <$> readIORef settings sendHeaders frameStream hpackEncoder headersList splitter flags - let _waitHeaders = waitHeadersWithStreamId sid headers + let _waitHeaders = waitHeadersWithStreamId sid headersFrames let _waitData = do (fh, fp) <- waitFrameWithTypeIdForStreamId sid [FrameRSTStream, FrameData] frames case fp of @@ -479,7 +541,7 @@ -> Chan (StreamId, Chan (FrameHeader, Either e FramePayload), StreamId) -> DynamicTable -> IO () -incomingHPACKFramesLoop frames headers pushPromises hpackDecoder = forever $ do +incomingHPACKFramesLoop frames hdrs pushPromises hpackDecoder = forever $ do (fh, fp) <- waitFrameWithTypeId [ FrameRSTStream , FramePushPromise , FrameHeaders @@ -513,11 +575,11 @@ go lastFh (Left err) _ -> error "waitFrameWithTypeIdForStreamId returned an unknown frame" else do - hdrs <- decodeHeader hpackDecoder buffer - writeChan headers (curFh, sId, Right hdrs) + newHdrs <- decodeHeader hpackDecoder buffer + writeChan hdrs (curFh, sId, Right newHdrs) go curFh (Left err) = - writeChan headers (curFh, sId, (Left $ HTTP2.fromErrorCodeId err)) + writeChan hdrs (curFh, sId, (Left $ HTTP2.fromErrorCodeId err)) go fh pattern @@ -559,7 +621,8 @@ newOutgoingFlowControl settings sid frames = do credit <- newIORef 0 let receive n = atomicModifyIORef' credit (\c -> (c + n, ())) - let withdraw n = do + let withdraw 0 = return 0 + withdraw n = do base <- initialWindowSize . _serverSettings <$> readIORef settings got <- atomicModifyIORef' credit (\c -> if base + c >= n @@ -596,8 +659,8 @@ -> PayloadSplitter -> (FrameFlags -> FrameFlags) -> IO StreamThread -sendHeaders s enc headers blockSplitter flagmod = do - headerBlockFragments <- blockSplitter <$> _encodeHeaders enc headers +sendHeaders s enc hdrs blockSplitter flagmod = do + headerBlockFragments <- blockSplitter <$> _encodeHeaders enc hdrs let framers = (HeadersFrame Nothing) : repeat ContinuationFrame let frames = zipWith ($) framers headerBlockFragments let modifiersReversed = (HTTP2.setEndHeader . flagmod) : repeat id @@ -625,11 +688,31 @@ in chunk : fixedSizeChunks len rest -sendData :: Http2Client -> Http2Stream -> (FrameFlags -> FrameFlags) -> ByteString -> IO () +-- | Sends data, chunked according to the server's preferred chunk size. +-- +-- This function does not respect HTTP2 flow-control and send chunks +-- sequentially. Hence, you should first ensure that you have enough +-- flow-control credit (with '_withdrawCredit') or risk a connection failure. +-- When you call _withdrawCredit keep in mind that HTTP2 has flow control at +-- the stream and at the connection level. If you use `http2-client` in a +-- multithreaded conext, you should avoid starving the connection-level +-- flow-control. +-- +-- If you want to send bytestrings that fit in RAM, you can use +-- 'Network.HTTP2.Client.Helpers.upload' as a function that implements +-- flow-control. +-- +-- This function does not send frames back-to-back, that is, other frames may +-- get interleaved between two chunks (for instance, to give priority to other +-- streams, although no priority queue exists in `http2-client` so far). +-- +-- Please refer to '_sendDataChunk' and '_withdrawCredit' as well. +sendData :: Http2Client -> Http2Stream -> FlagSetter -> ByteString -> IO () sendData conn stream flagmod dat = do splitter <- _paylodSplitter conn let chunks = splitter dat let pairs = reverse $ zip (flagmod : repeat id) (reverse chunks) + when (null chunks) $ _sendDataChunk stream flagmod "" forM_ pairs $ \(flags, chunk) -> _sendDataChunk stream flags chunk sendDataFrame @@ -745,8 +828,8 @@ loop where loop = do - tuple@(fH, sId, headers) <- readChan chan - if test fH sId headers + tuple@(fH, sId, hdrs) <- readChan chan + if test fH sId hdrs then return tuple else loop diff --git a/src/Network/HTTP2/Client/FrameConnection.hs b/src/Network/HTTP2/Client/FrameConnection.hs --- a/src/Network/HTTP2/Client/FrameConnection.hs +++ b/src/Network/HTTP2/Client/FrameConnection.hs @@ -3,9 +3,10 @@ {-# LANGUAGE RankNTypes #-} module Network.HTTP2.Client.FrameConnection ( - Http2FrameConnection + Http2FrameConnection(..) , newHttp2FrameConnection -- * Interact at the Frame level. + , Http2ServerStream(..) , Http2FrameClientStream(..) , makeFrameClientStream , sendOne diff --git a/src/Network/HTTP2/Client/Helpers.hs b/src/Network/HTTP2/Client/Helpers.hs --- a/src/Network/HTTP2/Client/Helpers.hs +++ b/src/Network/HTTP2/Client/Helpers.hs @@ -1,10 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} -module Network.HTTP2.Client.Helpers where +-- | A toolbox with high-level functions to interact with an established HTTP2 +-- conection. +-- +-- These helpers make the assumption that you want to work in a multi-threaded +-- environment and that you want to send and receiving whole HTTP requests at +-- once (i.e., you do not care about streaming individual HTTP +-- requests/responses but want to make many requests). +module Network.HTTP2.Client.Helpers ( + -- * Sending and receiving HTTP body + upload + , waitStream + , fromStreamResult + , onPushPromise + , StreamResult + , StreamResponse + -- * Diagnostics + , ping + , TimedOut + , PingReply + ) where import Data.Time.Clock (UTCTime, getCurrentTime) import qualified Network.HTTP2 as HTTP2 import qualified Network.HPACK as HPACK import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race) import Control.Monad (forever) @@ -42,9 +63,58 @@ -- | An HTTP2 response, once fully received, is made of headers and a payload. type StreamResponse = (HPACK.HeaderList, ByteString) +-- | Uploads a whole HTTP body at a time. +-- +-- This function should be called at most once per stream. This function +-- closes the stream with HTTP2.setEndStream chunk at the end. If you want to +-- post data (e.g., streamed chunks) your way to avoid loading a whole +-- bytestring in RAM, please study the source code of this function first. +-- +-- This function sends one chunk at a time respecting by preference: +-- - server's flow control desires +-- - server's chunking preference +-- +-- Uploading an empty bytestring will send a single DATA frame with +-- setEndStream and no payload. +upload :: ByteString + -- ^ HTTP body. + -> Http2Client + -- ^ The client. + -> OutgoingFlowControl + -- ^ The outgoing flow control for this client. (We might remove this + -- argument in the future because we can get it from the previous + -- argument. + -> Http2Stream + -- ^ The corresponding HTTP stream. + -> OutgoingFlowControl + -- ^ The flow control for this stream. + -> IO () +upload "" conn _ stream _ = do + sendData conn stream HTTP2.setEndStream "" +upload dat conn connectionFlowControl stream streamFlowControl = do + let wanted = ByteString.length dat + + gotStream <- _withdrawCredit streamFlowControl wanted + got <- _withdrawCredit connectionFlowControl gotStream + -- Recredit the stream flow control with the excedent we cannot spend on + -- the connection. + _receiveCredit streamFlowControl (gotStream - got) + + let uploadChunks flagMod = + sendData conn stream flagMod (ByteString.take got dat) + + if got == wanted + then + uploadChunks HTTP2.setEndStream + else do + uploadChunks id + upload (ByteString.drop got dat) conn connectionFlowControl stream streamFlowControl + -- | Wait for a stream until completion. -- --- This function is fine if you don't want to consume results in chunks. +-- This function is fine if you don't want to consume results in chunks. See +-- 'fromStreamResult' to collect the complicated 'StreamResult' into a simpler +-- 'StramResponse'. waitStream :: Http2Stream -> IncomingFlowControl -> IO StreamResult waitStream stream streamFlowControl = do (_,_,hdrs) <- _waitHeaders stream @@ -64,9 +134,9 @@ -- using the `Either HTTP2.ErrorCode` monad. fromStreamResult :: StreamResult -> Either HTTP2.ErrorCode StreamResponse fromStreamResult (headersE, chunksE) = do - headers <- headersE + hdrs <- headersE chunks <- sequence chunksE - return (headers, mconcat chunks) + return (hdrs, mconcat chunks) -- | Sequentially wait for every push-promise with a handler. -- diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,11 @@ +import Network.HTTP2.Client +import Network.HTTP2.Client.FrameConnection + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + -- only demonstrates test-client setup + let serverstream = Http2ServerStream undefined + let makeframestream sid = Http2FrameClientStream (print . fmap snd) sid + let fakeFrameConn = Http2FrameConnection makeframestream serverstream undefined + _ <- wrapFrameClient fakeFrameConn 2048 2048 [] + putStrLn "OK"