http2-tls 0.2.7 → 0.2.8

raw patch · 5 files changed

+351/−16 lines, 5 filesdep +asyncdep +cryptondep +http-typesdep ~bytestringdep ~http2dep ~network-controlnew-component:exe:h2-clientnew-component:exe:h2-serverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, crypton, http-types, http2-tls, tls-session-manager

Dependency ranges changed: bytestring, http2, network-control, tls

API changes (from Hackage documentation)

Files

• http2-tls.cabal +61/−16
• util/Client.hs +29/−0
• util/Server.hs +55/−0
• util/h2-client.hs +122/−0
• util/h2-server.hs +84/−0

@@ -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 <kazu@iij.ad.jp>@@ -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

@@ -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)

@@ -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

@@ -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}) "<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}) "<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+        }

@@ -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}) "<file>")+        "a file to store negotiated secrets"+    , Option+        ['c']+        ["cert"]+        (ReqArg (\fl o -> o{optCertFile = fl}) "<file>")+        "certificate file"+    , Option+        ['k']+        ["key"]+        (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>")+        "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] <addr> <port>"++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