http2-client 0.8.0.0 → 0.8.0.1

raw patch · 4 files changed

+22/−476 lines, 4 filesdep −data-default-classdep −optparse-applicativedep ~asyncdep ~basedep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: data-default-class, optparse-applicative

Dependency ranges changed: async, base, bytestring, http2, time, tls

API changes (from Hackage documentation)

Files

• README.md +5/−5
• app/Main.hs +0/−314
• examples/SimpleGet.lhs +0/−127
• http2-client.cabal +17/−30

@@ -57,12 +57,12 @@ 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.+various flow-control parameters. This binary lives in a separate package+at https://github.com/lucasdicioccio/http2-client-exe . -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.+The Haddocks, at https://hackage.haskell.org/package/http2-client, should have+plenty implementation details, so please have a look.  Otherwise, you can ask+help by creating an Issue on the bug-tracker.  ### Opening a stream 

@@ -1,314 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-module Main where--import           Control.Concurrent (forkIO, myThreadId, throwTo, threadDelay)-import           Control.Concurrent.Async (async, waitAnyCancel)-import           Control.Monad (forever, when, void)-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as ByteString-import           Data.Default.Class (def)-import           Data.Maybe (fromMaybe)-import           Data.Monoid ((<>))-import           Data.Time.Clock (diffUTCTime, getCurrentTime)-import qualified Network.HTTP2 as HTTP2-import qualified Network.TLS as TLS-import qualified Network.TLS.Extra.Cipher as TLS-import           Options.Applicative-import           System.IO--import Network.HTTP2.Client-import Network.HTTP2.Client.Helpers--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--data Verbosity = Verbose | NonVerbose-  deriving Show--data UseTLS = UseTLS | PlainText-  deriving Show--data QueryArgs = QueryArgs {-    _host                       :: !HostName-  , _port                       :: !PortNumber-  , _verb                       :: !Verb-  , _path                       :: !Path-  , _extraHeaders               :: ![(ByteString, ByteString)]-  , _extraTrailers              :: ![(ByteString, ByteString)]-  , _postData                   :: !(Maybe PostData)-  , _interPingDelay             :: !Int-  , _pingTimeout                :: !Int-  , _interFlowControlUpdates    :: !Int-  , _settingsMaxConcurrency     :: !Int-  , _settingsAllowServerPush    :: !ServerPushSwitch-  , _settingsMaxFrameSize       :: !Int-  , _settingsMaxHeaderBlockSize :: !Int-  , _settingsInitialWindowSize  :: !Int-  , _initialWindowKick          :: !Int-  , _concurrentQueriesCount     :: !Int-  , _numberQueries              :: !Int-  , _finalDelay                 :: !Int-  , _finalMessage               :: !ByteString-  , _encoderBufsize             :: !Int-  , _decoderBufsize             :: !Int-  , _downloadPrefix             :: !FilePath-  , _verboseDebug               :: !Verbosity-  , _useTLS                     :: !UseTLS-  } deriving Show--clientArgs :: Parser QueryArgs-clientArgs =-    QueryArgs-        <$> host-        <*> port-        <*> verb-        <*> path-        <*> extraHeaders-        <*> extraTrailers-        <*> postData-        <*> milliseconds "inter-ping-delay-ms" 0-        <*> milliseconds "ping-timeout-ms" 5000-        <*> milliseconds "inter-flow-control-updates-ms" 1000-        <*> concurrency-        <*> allowPush-        <*> frameBytes-        <*> headersBytes-        <*> initialWindowBytes-        <*> initialWindowKick-        <*> numConcurrentThreads-        <*> numQueriesPerThread-        <*> milliseconds "delay-before-quitting-ms" 0-        <*> kthxByeMessage-        <*> encoderBufSize-        <*> decoderBufSize-        <*> downloadPrefix-        <*> verboseDebug-        <*> useTLS-  where-    bstrOption = fmap ByteString.pack . strOption-    milliseconds what base = fmap (*1000) $ option auto (long what <> value base)-    keyval kv = let (k,v1) = ByteString.break (== ':') kv in (k, ByteString.drop 1 v1)--    host = strOption (long "host" <> value "127.0.0.1")-    path = bstrOption (long "path" <> value "/")-    port = option auto (long "port" <> value 443)-    verb = bstrOption (long "verb" <> value "GET")-    extraHeaders = many (fmap keyval $ bstrOption (short 'H'))-    extraTrailers = many (fmap keyval $ bstrOption (short 'T'))-    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)-    headersBytes = option auto (long "max-headers-list-size" <> value 1048576)-    initialWindowBytes = option auto (long "initial-window-size" <> value 10485760)-    initialWindowKick  = option auto (long "initial-window-kick" <> value 0)-    numConcurrentThreads = option auto (long "num-concurrent-threads" <> value 1)-    numQueriesPerThread = option auto (long "num-queries-per-thread" <> value 1)-    kthxByeMessage = bstrOption (long "exit-greeting" <> value "kthxbye (>;_;<)")-    encoderBufSize = option auto (long "hpack-encoder-buffer-size" <> value 4096)-    decoderBufSize = option auto (long "hpack-decoder-buffer-size" <> value 4096)-    downloadPrefix = strOption (long "push-files-prefix" <> value ":stdout-pp")-    verboseDebug = flag NonVerbose Verbose (long "verbose")-    useTLS = flag UseTLS PlainText (long "plain-text")--main :: IO ()-main = execParser opts >>= client-  where-    opts = info (helper <*> clientArgs) (mconcat [-        fullDesc-      , header "http2-client-exe: a CLI HTTP2 client written in Haskell"-      ])--client :: QueryArgs -> IO ()-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 (_extraTrailers, _postData) of-        ([], (Just (PostBytestring dataPayload))) ->-            return $ (id, upload dataPayload HTTP2.setEndStream)-        ([], (Just (PostFileContent filepath)))   -> do-            dataPayload <- ByteString.readFile filepath-            return $ (id, upload dataPayload HTTP2.setEndStream)-        ([], Nothing) ->-            return $ (HTTP2.setEndStream, \_ _ _ _ -> return ())-        (_, (Just (PostBytestring dataPayload))) ->-            return $ (id, (\c ofc s sofc -> do-                upload dataPayload id c ofc s sofc-                trailers s _extraTrailers HTTP2.setEndStream-                ))-        (_, (Just (PostFileContent filepath)))   -> do-            dataPayload <- ByteString.readFile filepath-            return $ (id, (\c ofc s sofc -> do-                upload dataPayload id c ofc s sofc-                trailers s _extraTrailers HTTP2.setEndStream-                ))-        (_, Nothing) ->-            return $ (id, (\_ _ s _ -> do-                trailers s _extraTrailers HTTP2.setEndStream-                ))--    let headersPairs    = [ (":method", _verb)-                          , (":scheme", "https")-                          , (":path", _path)-                          , (":authority", ByteString.pack _host)-                          ] <> _extraHeaders <> [("Trailer", ByteString.unwords $ fmap fst _extraTrailers)]---    let ppHandler n idx _ stream ppHdrs streamFlowControl _ = void $ forkIO $ do-            let pushpath = fromMaybe "unspecified-path" (lookup ":path" ppHdrs)-            timePrint ("push stream started" :: String, pushpath)-            ret <- fromStreamResult <$> waitStream stream streamFlowControl (ppHandler n idx)-            either (\e -> timePrint e) (dump PushPromiseFile pushpath n idx _downloadPrefix) ret-            timePrint ("push stream ended" :: String)--    let conf = [ (HTTP2.SettingsMaxFrameSize, _settingsMaxFrameSize)-               , (HTTP2.SettingsMaxConcurrentStreams, _settingsMaxConcurrency)-               , (HTTP2.SettingsMaxHeaderBlockSize, _settingsMaxHeaderBlockSize)-               , (HTTP2.SettingsInitialWindowSize, _settingsInitialWindowSize)-               , (HTTP2.SettingsEnablePush, case _settingsAllowServerPush of-                   PushEnabled -> 1 ; PushDisabled -> 0)-               ]-    timePrint conf--    let tlsSetting = case _useTLS of-            UseTLS ->-                Just tlsParams-            PlainText ->-                Nothing-    frameConn <- newHttp2FrameConnection _host _port tlsSetting-    let wrappedFrameConn = frameConn {-            _makeFrameClientStream = \sid ->-                let frameClient = (_makeFrameClientStream frameConn) sid-                in frameClient {-                       _sendFrames = \mkFrames -> do-                           xs <- mkFrames-                           print $ (">>> "::String, _getStreamId frameClient, map snd xs)-                           _sendFrames frameClient (pure xs)-                   }-          , _serverStream =-              let-                currentServerStrean = _serverStream frameConn-              in-                currentServerStrean {-                  _nextHeaderAndFrame = do-                      hdrFrame@(hdr,_) <- _nextHeaderAndFrame currentServerStrean-                      print ("<<< "::String, HTTP2.streamId hdr, hdrFrame)-                      return hdrFrame-                }-          }-    parentThread <- myThreadId-    let withConn = case _verboseDebug of-            Verbose ->-                runHttp2Client wrappedFrameConn _encoderBufsize _decoderBufsize conf defaultGoAwayHandler printUnhandledFrame-            NonVerbose ->-                runHttp2Client frameConn _encoderBufsize _decoderBufsize conf (throwTo parentThread) ignoreFallbackHandler--    withConn $ \conn -> do-      _addCredit (_incomingFlowControl conn) _initialWindowKick-      _ <- forkIO $ forever $ do-              updated <- _updateWindow $ _incomingFlowControl conn-              when updated $ timePrint ("sending flow-control update" :: String)-              threadDelay _interFlowControlUpdates--      _ <- forkIO $ when (_interPingDelay > 0) $ forever $ do-          threadDelay _interPingDelay-          (t0, t1, pingReply) <- ping conn _pingTimeout "pingpong"-          timePrint $ ("ping-reply:" :: String, pingReply, diffUTCTime t1 t0)--      let go 0 idx = timePrint $ "done worker: " <> show idx-          go n idx = do-              _ <- (withHttp2Stream conn $ \stream ->-                      let initStream =-                              headers stream headersPairs headersFlags-                          handler streamINFlowControl streamOUTFlowControl = do-                              timePrint $ "stream started " <> show (idx, n)-                              _ <- async $ do-                                  dataPostFunction conn-                                                   (_outgoingFlowControl conn)-                                                   stream-                                                   streamOUTFlowControl-                              ret <-  fromStreamResult <$> waitStream stream streamINFlowControl (ppHandler n idx)-                              either (\e -> timePrint e) (dump MainFile _path n idx _downloadPrefix) ret-                              timePrint $ "stream ended " <> show (idx, n)-                      in StreamDefinition initStream handler)-              go (n - 1) idx--      _ <- waitAnyCancel =<< traverse (async . go _numberQueries) [1 .. _concurrentQueriesCount]--      when (_finalDelay > 0) (threadDelay _finalDelay)---      _gtfo conn HTTP2.NoError _finalMessage-  where-    tlsParams = TLS.ClientParams {-          TLS.clientWantSessionResume    = Nothing-        , TLS.clientUseMaxFragmentLength = Nothing-        , TLS.clientServerIdentification = (_host, ByteString.pack $ show _port)-        , TLS.clientUseServerNameIndication = True-        , TLS.clientShared               = def-        , TLS.clientHooks                = def { TLS.onServerCertificate = \_ _ _ _ -> return []-                                               }-        , TLS.clientSupported            = def { TLS.supportedCiphers = TLS.ciphersuite_default }-        , TLS.clientDebug                = def-        }--data DumpType = MainFile | PushPromiseFile--dump :: DumpType -> Path -> Int -> Int -> FilePath -> StreamResponse -> IO ()-dump MainFile _ _ _ ":none" (hdrs, _, trls) = do-    timePrint hdrs-    timePrint trls-dump MainFile _ _ _ ":stdout" (hdrs, body, trls) = do-    timePrint hdrs-    ByteString.putStrLn body-    timePrint trls-dump PushPromiseFile _ _ _ ":stdout" (hdrs, _, trls) = do-    timePrint hdrs-    timePrint trls-dump MainFile _ _ _ ":stdout-pp" (hdrs, body, trls) = do-    timePrint hdrs-    ByteString.putStrLn body-    timePrint trls-dump PushPromiseFile _ _ _ ":stdout-pp" (hdrs, body, trls) = do-    timePrint hdrs-    ByteString.putStrLn body-    timePrint trls-dump _ querystring nquery nthread prefix (hdrs, body, trls) = do-    timePrint hdrs-    ByteString.writeFile filepath body-    timePrint trls-  where-    filepath = mconcat [ prefix-                       , "/" -                       , show nquery-                       , "."-                       , show nthread-                       , ByteString.unpack $ cleanPath querystring-                       ]-    cleanPath = ByteString.takeWhile (/= '?')-              . ByteString.map (\c -> if c == '/' then '_' else c)--timePrint :: Show a => a -> IO ()-timePrint x = do-    tst <- getCurrentTime-    ByteString.hPutStrLn stderr $ ByteString.pack $ show (tst, x)--printUnhandledFrame :: FallBackFrameHandler-printUnhandledFrame (fh,fp) = timePrint ("UNHANDLED:"::String, fh, fp)

@@ -1,127 +0,0 @@-First you need some imports and pragmas to make our life easier while typing-string literals.--> {-# LANGUAGE OverloadedStrings #-}--Main http2-client imports.--> import Network.HTTP2.Client-> import Network.HTTP2.Client.Helpers--Other imports, that we may eventually hide.--> import Network.HTTP2-> import Data.Default.Class (def)-> import Network.TLS as TLS-> import Network.TLS.Extra.Cipher as TLS-> -> main :: IO ()-> main = do--First, create a connection, you need to specify the host and port you want to-connect to. Unlike HTTP, HTTP2 proposes to use TLS, hence, the port should-almost always be 443 instead of 80.-->     frameConn <- newHttp2FrameConnection "www.google.com" 443 (Just tlsParams )--The 'runHttp2Client' function takes control of the current thread so that we-never leave an internal thread leaking, even in presence of asynchronous-exceptions (likely in networked systems). Hence, the body of the logic we want-to perform is passed as a callback to 'runHttp2Client'. This callback is the-last argument for synctactic reason.--We also need to give more arguments to 'runHttp2Client'. The 8k values-corresponds to header sizes for sending/receiving. If you expect to receive or-send queries with more than 8MB of sent/received buffers, then you should tune-these values. The settings at the list gives the server a warrant to send more-bytes as soon as the server is ready to send queries (cf. HTTP2 flow control).-->     runHttp2Client frameConn 8192 8192 [(SettingsInitialWindowSize,10000000)] defaultGoAwayHandler ignoreFallbackHandler $ \conn -> do--We need to update the flow-control window for a snappy experience, so add-credit to the whole connection (else the SettingsInitialWindowSize would be-useless). Then, we immediately transfer credit to the server using-_updateWindow. We don't expect to receive more data for this connection so-we're good to go, but in a long-running application we would have to query this-function a number of time.-->       let fc = _incomingFlowControl conn->       _addCredit fc 10000000->       _ <- _updateWindow fc--Prepare the HTTP request using, first meta-headers, then normal headers.-->       let requestHeaders = [ (":method", "GET")->                            , (":scheme", "https")->                            , (":path", "?q=http2")->                            , (":authority", "www.google.com")->                            ]--Start a new stream. A new stream opened by a client takes two steps: first we-initialize the stream then we wait for a reply (i.e., we handle the reply).  If-you were sending an HTTP POST you would be sending data from the client to the-server, which requires outbound flow-control too.-->       _ <- withHttp2Stream conn $ \stream ->->           let--For a simple HTTP GET, the headers constitute the whole query. We don't plan to-send more HTTP headers in continuation frames, hence we tell the server that-the headers are sent (so that the server can start generating a response). We-also tell the server that we're not gonna send more data with the setEndStream-flag.-->             initStream = headers stream requestHeaders (setEndHeader . setEndStream)--The handler uses the high-level waitStream, which blocks and waits for the-whole query result. The fromStreamResult coalesces every single frames from the-response (each of which may fail) as a single tuple with headers and the body-reply, wrapped in a single error.--If you expected the server to send you some data you can use onPushPromise with-a handler with the same type and 'waitStream' mechanism as the-client-originated streams (however with its own flow-control context).-->             resetPushPromises _ pps _ _ _ = _rst pps RefusedStream->->             handler sfc _ = do->                 waitStream stream sfc resetPushPromises >>= print . fromStreamResult--We've defined an initializer and a handler so far.-->           in --We need to package the initializer and the handler in a StreamDefinition-object. Once you're done, the _startStream function will manage your stream-synchronously. If you wanted to run multiple concurrent queries then you should-have one async per stream, and pay attention to the return value of-_startStream.-->             StreamDefinition initStream handler--We are done, congratz!-->       putStrLn "done"->       _goaway conn NoError "https://github.com/lucasdicioccio/http2-client example"--You need to pass some TLS parameters. Here are a settings that could work with-an SSL verification that accepts any server certificate.--> tlsParams :: ClientParams-> tlsParams = TLS.ClientParams {->     TLS.clientWantSessionResume    = Nothing->   , TLS.clientUseMaxFragmentLength = Nothing->   , TLS.clientServerIdentification = ("127.0.0.1", "")->   , TLS.clientUseServerNameIndication = True->   , TLS.clientShared               = def->   , TLS.clientHooks                = def { TLS.onServerCertificate = \_ _ _ _ -> return [] }->   , TLS.clientSupported            = def { TLS.supportedCiphers = TLS.ciphersuite_default }->   , TLS.clientDebug                = def->   }---An example output is as below:--$ http2-client-example-Right ([(":status","302"),("location","https://www.google.fr/?q=http2&gws_rd=cr&ei=7mOXWY6IMsSya_f2gsAJ"),("cache-control","private"),("content-type","text/html; charset=UTF-8"),("p3p","CP=\"This is not a P3P policy! See https://www.google.com/support/accounts/answer/151657?hl=en for more info.\""),("date","Fri, 18 Aug 2017 22:02:22 GMT"),("server","gws"),("content-length","269"),("x-xss-protection","1; mode=block"),("x-frame-options","SAMEORIGIN"),("set-cookie","NID=110=KvJPXSY6bwoZ1nJZe7LkRLu8GfSQIis1BCmh0u6agjDqyu4Ny8iAbmtZJSUXRen47uBjVmumFF8itvEDqQkVWTK3rKS1SAviGtzcoFj4Qel7FH5FpB2hvijgN1JFEbNM; expires=Sat, 17-Feb-2018 22:02:22 GMT; path=/; domain=.google.com; HttpOnly"),("alt-svc","quic=\":443\"; ma=2592000; v=\"39,38,37,35\"")],"<HTML><HEAD><meta http-equiv=\"content-type\" content=\"text/html;charset=utf-8\">\n<TITLE>302 Moved</TITLE></HEAD><BODY>\n<H1>302 Moved</H1>\nThe document has moved\n<A HREF=\"https://www.google.fr/?q=http2&amp;gws_rd=cr&amp;ei=7mOXWY6IMsSya_f2gsAJ\">here</A>.\r\n</BODY></HTML>\r\n")-done

@@ -1,5 +1,5 @@ name:                http2-client-version:             0.8.0.0+version:             0.8.0.1 synopsis:            A native HTTP2 client library. description:         Please read the README.md at the homepage. homepage:            https://github.com/lucasdicioccio/http2-client@@ -33,35 +33,22 @@                      , tls >= 1.4 && < 2   default-language:    Haskell2010 -executable http2-client-exe-  hs-source-dirs:      app-  main-is:             Main.hs-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2-  build-depends:       base-                     , async-                     , bytestring-                     , data-default-class-                     , http2-                     , http2-client-                     , optparse-applicative-                     , time-                     , tls-  default-language:    Haskell2010--executable http2-client-example-simple-get-  hs-source-dirs:      examples-  main-is:             SimpleGet.lhs-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2-  build-depends:       base-                     , async-                     , bytestring-                     , data-default-class-                     , http2-                     , http2-client-                     , optparse-applicative-                     , time-                     , tls-  default-language:    Haskell2010+-- Commented-out to avoid distribution+--+--executable http2-client-example-simple-get+--  hs-source-dirs:      examples+--  main-is:             SimpleGet.lhs+--  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -O2+--  build-depends:       base+--                     , async+--                     , bytestring+--                     , data-default-class+--                     , http2+--                     , http2-client+--                     , optparse-applicative+--                     , time+--                     , tls+--  default-language:    Haskell2010  test-suite http2-client-test   type:                exitcode-stdio-1.0