http2-client-exe (empty) → 0.1.0.0
raw patch · 6 files changed
+406/−0 lines, 6 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, data-default-class, http2, http2-client, optparse-applicative, time, tls
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +11/−0
- Setup.hs +2/−0
- app/Main.hs +314/−0
- http2-client-exe.cabal +46/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for http2-client-exe++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# http2-client-exe++A reference command-line client for 'http2-client'.++Allows testing the library but can sometimes come in handy for debugging+servers/load-balancer installation purposes.++See https://github.com/lucasdicioccio/http2-client for the library.++This binary is distributed as a separate package to avoid compiling+command-line interface clients when un-needed.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,314 @@+{-# 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)
+ http2-client-exe.cabal view
@@ -0,0 +1,46 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 2435e1500ee58000db937e0d9eb76a8758c70f4a4de86034c9313a08bab92df8++name: http2-client-exe+version: 0.1.0.0+synopsis: A command-line http2 client.+description: A reference command-line tool using http2-client. Please see the README on GitHub at <https://github.com/lucasdicioccio/http2-client-exe#readme>+category: Web+homepage: https://github.com/lucasdicioccio/http2-client-exe#readme+bug-reports: https://github.com/lucasdicioccio/http2-client-exe/issues+author: Lucas DiCioccio+maintainer: lucas@dicioccio.fr+copyright: 2018 Lucas DiCioccio+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/lucasdicioccio/http2-client-exe++executable http2-client-exe+ main-is: Main.hs+ other-modules:+ Paths_http2_client_exe+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ async+ , base >=4.7 && <5+ , bytestring+ , data-default-class+ , http2+ , http2-client+ , optparse-applicative+ , time+ , tls+ default-language: Haskell2010