diff --git a/http2-tls.cabal b/http2-tls.cabal --- a/http2-tls.cabal +++ b/http2-tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: http2-tls -version: 0.2.7 +version: 0.2.8 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -18,6 +18,10 @@ flag crypton description: Use the crypton-x509-* package family instead of x509-* +flag devel + description: Development commands + default: False + library exposed-modules: Network.HTTP2.TLS.Client @@ -36,27 +40,68 @@ ghc-options: -Wall build-depends: base >=4.9 && <5, - bytestring >= 0.10, - http2 >=5.1 && < 5.2, - data-default-class >= 0.1 && < 0.2, - network >= 3.1.4, - time-manager >= 0.0.1 && < 0.1, - unliftio >= 0.2 && < 0.3, - network-run >= 0.2.6 && < 0.3, - network-control >= 0.0.2 && < 0.1, - recv >= 0.1.0 && < 0.2, - utf8-string >= 1.0 && < 1.1 + bytestring >=0.10, + http2 >=5.1 && <5.2, + data-default-class >=0.1 && <0.2, + network >=3.1.4, + time-manager >=0.0.1 && <0.1, + unliftio >=0.2 && <0.3, + network-run >=0.2.6 && <0.3, + network-control >=0.1 && <0.2, + recv >=0.1.0 && <0.2, + utf8-string >=1.0 && <1.1 if flag(crypton) build-depends: - -- If we raise the lower bound on @tls@, then the @crypton@ flag - -- becomes useless and we should remove it. - tls >=1.7 && < 2.1, - crypton-x509-store >= 1.6 && < 1.7, - crypton-x509-validation >= 1.6 && < 1.7 + tls >=1.7 && <2.1, + crypton-x509-store >=1.6 && <1.7, + crypton-x509-validation >=1.6 && <1.7 else build-depends: tls <1.7, x509-store, x509-validation + +executable h2-client + main-is: h2-client.hs + hs-source-dirs: util + other-modules: Client + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall -threaded -rtsopts + build-depends: + base >=4.9 && <5, + async, + bytestring, + http-types, + http2, + http2-tls, + tls + + if flag(devel) + + else + buildable: False + +executable h2-server + main-is: h2-server.hs + hs-source-dirs: util + other-modules: Server + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall -threaded + build-depends: + base >=4.9 && <5, + bytestring, + crypton, + http-types, + http2, + http2-tls, + tls, + tls-session-manager + + if flag(devel) + + else + buildable: False diff --git a/util/Client.hs b/util/Client.hs new file mode 100644 --- /dev/null +++ b/util/Client.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Client where + +import Control.Concurrent.Async +import qualified Control.Exception as E +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Types + +import Network.HTTP2.Client + +client :: Int -> [Path] -> Client () +client n0 paths sendRequest _aux = do + ex <- E.try $ foldr1 concurrently_ $ map (client' n0 sendRequest) paths + case ex of + Right () -> return () + Left e -> print (e :: HTTP2Error) + +client' :: Int -> SendRequest -> Path -> IO () +client' n0 sendRequest path = loop n0 + where + req = requestNoBody methodGet path [] + loop 0 = return () + loop n = do + sendRequest req $ \rsp -> do + print $ responseStatus rsp + getResponseBodyChunk rsp >>= C8.putStrLn + loop (n - 1) diff --git a/util/Server.hs b/util/Server.hs new file mode 100644 --- /dev/null +++ b/util/Server.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Server where + +import Control.Monad +import Crypto.Hash (Context, SHA1) -- crypton +import qualified Crypto.Hash as CH +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Builder (byteString) +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Types +import Network.HTTP2.Server + +server :: Server +server req _aux sendResponse = case requestMethod req of + Just "GET" + | requestPath req == Just "/" -> sendResponse responseHello [] + Just "POST" -> sendResponse (responseEcho req) [] + _ -> sendResponse response404 [] + +responseHello :: Response +responseHello = responseBuilder ok200 header body + where + header = [("Content-Type", "text/plain")] + body = byteString "Hello, world!\n" + +response404 :: Response +response404 = responseBuilder notFound404 header body + where + header = [("Content-Type", "text/plain")] + body = byteString "Not found\n" + +responseEcho :: Request -> Response +responseEcho req = setResponseTrailersMaker h2rsp maker + where + h2rsp = responseStreaming ok200 header streamingBody + header = [("Content-Type", "text/plain")] + streamingBody write _flush = loop + where + loop = do + bs <- getRequestBodyChunk req + unless (B.null bs) $ do + void $ write $ byteString bs + loop + maker = trailersMaker (CH.hashInit :: Context SHA1) + +-- Strictness is important for Context. +trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker +trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)] + where + sha1 = C8.pack $ show $ CH.hashFinalize ctx +trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' + where + ctx' = CH.hashUpdate ctx bs diff --git a/util/h2-client.hs b/util/h2-client.hs new file mode 100644 --- /dev/null +++ b/util/h2-client.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Monad +import qualified Data.ByteString.Char8 as C8 +import Data.IORef +import Network.HTTP2.TLS.Client +import Network.TLS +import System.Console.GetOpt +import System.Environment +import System.Exit + +import Client + +data Options = Options + { optKeyLogFile :: Maybe FilePath + , optValidate :: Bool + , optResumption :: Bool + , opt0RTT :: Bool + , optNumOfReqs :: Int + } + deriving (Show) + +defaultOptions :: Options +defaultOptions = + Options + { optKeyLogFile = Nothing + , optValidate = False + , optResumption = False + , opt0RTT = False + , optNumOfReqs = 1 + } + +usage :: String +usage = "Usage: h2-client [OPTION] addr port [path]" + +options :: [OptDescr (Options -> Options)] +options = + [ Option + ['l'] + ["key-log-file"] + (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") + "a file to store negotiated secrets" + , Option + ['e'] + ["validate"] + (NoArg (\o -> o{optValidate = True})) + "validate server's certificate" + , Option + ['R'] + ["resumption"] + (NoArg (\o -> o{optResumption = True})) + "try session resumption" + , Option + ['Z'] + ["0rtt"] + (NoArg (\o -> o{opt0RTT = True})) + "try sending early data" + , Option + ['n'] + ["number-of-requests"] + (ReqArg (\n o -> o{optNumOfReqs = read n}) "") + "specify the number of requests" + ] + +showUsageAndExit :: String -> IO a +showUsageAndExit msg = do + putStrLn msg + putStrLn $ usageInfo usage options + exitFailure + +clientOpts :: [String] -> IO (Options, [String]) +clientOpts argv = + case getOpt Permute options argv of + (o, n, []) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> showUsageAndExit $ concat errs + +main :: IO () +main = do + args <- getArgs + (Options{..}, ips) <- clientOpts args + (host, port, paths) <- case ips of + [] -> showUsageAndExit usage + _ : [] -> showUsageAndExit usage + h : p : [] -> return (h, read p, ["/"]) + h : p : ps -> return (h, read p, C8.pack <$> ps) + ref <- newIORef Nothing + let keylog msg = case optKeyLogFile of + Nothing -> return () + Just file -> appendFile file (msg ++ "\n") + settings = + defaultSettings + { settingsValidateCert = optValidate + , settingsKeyLogger = keylog + , settingsSessionManager = sessionRef ref + } + run settings host port $ client optNumOfReqs paths + when (optResumption || opt0RTT) $ do + mr <- readIORef ref + case mr of + Nothing -> do + putStrLn "No session data" + exitFailure + _ -> do + let settings2 = + defaultSettings + { settingsValidateCert = optValidate + , settingsKeyLogger = keylog + , settingsWantSessionResume = mr + , settingsUseEarlyData = opt0RTT + } + run settings2 host port $ client optNumOfReqs paths + +sessionRef :: IORef (Maybe (SessionID, SessionData)) -> SessionManager +sessionRef ref = + noSessionManager + { sessionEstablish = \sid sdata -> do + writeIORef ref $ Just (sid, sdata) + return Nothing + } diff --git a/util/h2-server.hs b/util/h2-server.hs new file mode 100644 --- /dev/null +++ b/util/h2-server.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import Network.HTTP2.TLS.Server +import Network.TLS (Credentials (..), credentialLoadX509) +import Network.TLS.SessionTicket +import System.Console.GetOpt +import System.Environment +import System.Exit + +import Server + +options :: [OptDescr (Options -> Options)] +options = + [ Option + ['l'] + ["key-log-file"] + (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") + "a file to store negotiated secrets" + , Option + ['c'] + ["cert"] + (ReqArg (\fl o -> o{optCertFile = fl}) "") + "certificate file" + , Option + ['k'] + ["key"] + (ReqArg (\fl o -> o{optKeyFile = fl}) "") + "key file" + ] + +showUsageAndExit :: String -> IO a +showUsageAndExit msg = do + putStrLn msg + putStrLn $ usageInfo usage options + exitFailure + +serverOpts :: [String] -> IO (Options, [String]) +serverOpts argv = + case getOpt Permute options argv of + (o, n, []) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> showUsageAndExit $ concat errs + +data Options = Options + { optKeyLogFile :: Maybe FilePath + , optCertFile :: FilePath + , optKeyFile :: FilePath + } + deriving (Show) + +defaultOptions :: Options +defaultOptions = + Options + { optKeyLogFile = Nothing + , optCertFile = "servercert.pem" + , optKeyFile = "serverkey.pem" + } + +usage :: String +usage = "Usage: h2-server [OPTION] " + +main :: IO () +main = do + args <- getArgs + (Options{..}, ips) <- serverOpts args + (host, port) <- case ips of + [h, p] -> return (h, p) + _ -> showUsageAndExit usage + Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile + sm <- newSessionTicketManager defaultConfig + let keylog msg = case optKeyLogFile of + Nothing -> return () + Just file -> appendFile file (msg ++ "\n") + settings = + defaultSettings + { settingsKeyLogger = keylog + , settingsSessionManager = sm + , settingsEarlyDataSize = 4096 + } + creds = Credentials [cred] + run settings creds host (read port) server