http2-tls 0.0.1 → 0.1.0

raw patch · 9 files changed

+212/−85 lines, 9 filesdep +crypton-x509-storedep +crypton-x509-validationdep ~http2PVP ok

version bump matches the API change (PVP)

Dependencies added: crypton-x509-store, crypton-x509-validation

Dependency ranges changed: http2

API changes (from Hackage documentation)

Files

• Network/HTTP2/TLS/Client.hs +56/−28
• Network/HTTP2/TLS/Client/Settings.hs +34/−0
• Network/HTTP2/TLS/Config.hs +17/−6
• Network/HTTP2/TLS/IO.hs +23/−10
• Network/HTTP2/TLS/Internal.hs +12/−0
• Network/HTTP2/TLS/Server.hs +16/−7
• Network/HTTP2/TLS/Server/Settings.hs +48/−0
• Network/HTTP2/TLS/Settings.hs +0/−31
• http2-tls.cabal +6/−3

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}  -- | Running an HTTP\/2 client over TLS.@@ -10,11 +11,20 @@     HostName,     PortNumber,     runTLS,++    -- * Settings+    Settings,+    defaultSettings,+    settingsKeyLogger,+    settingsValidateCert,+    settingsCAStore,+    settingsAddrInfoFlags, ) where  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import Data.Default.Class (def)+import Data.X509.Validation (validateDefault) import Network.HTTP2.Client (     Client,     ClientConfig (..),@@ -24,55 +34,64 @@ import Network.TLS hiding (HostName) import qualified UnliftIO.Exception as E +import Network.HTTP2.TLS.Client.Settings import Network.HTTP2.TLS.Config import Network.HTTP2.TLS.IO-import Network.HTTP2.TLS.Settings+import Network.HTTP2.TLS.Internal (gclose)+import qualified Network.HTTP2.TLS.Server.Settings as Server import Network.HTTP2.TLS.Supported  ----------------------------------------------------------------  -- | Running a TLS client. runTLS-    :: HostName+    :: Settings+    -> HostName     -> PortNumber     -> ByteString     -- ^ ALPN-    -> (Context -> IO a)+    -> (Context -> SockAddr -> SockAddr -> IO a)     -> IO a-runTLS serverName port alpn action =-    E.bracket open close $ \sock -> do+runTLS settings serverName port alpn action =+    E.bracket open gclose $ \sock -> do+        mysa <- getSocketName sock+        peersa <- getPeerName sock         E.bracket (contextNew sock params) bye $ \ctx -> do             handshake ctx-            action ctx+            action ctx mysa peersa   where-    open = openTCP serverName port-    params = getClientParams serverName alpn False+    open = openTCP (settingsAddrInfoFlags settings) serverName port+    params = getClientParams settings serverName alpn  -- | Running an HTTP\/2 client over TLS (over TCP).-run :: HostName -> PortNumber -> Client a -> IO a-run serverName port client =-    runTLS serverName port "h2" $ \ctx ->-        run' "https" serverName (sendTLS ctx) (recvTLS ctx) client+run :: Settings -> HostName -> PortNumber -> Client a -> IO a+run settings serverName port client =+    runTLS settings serverName port "h2" $ \ctx mysa peersa ->+        run' "https" serverName (sendTLS ctx) (recvTLS ctx) mysa peersa client  -- | Running an HTTP\/2 client over TCP. runH2C :: HostName -> PortNumber -> Client a -> IO a runH2C serverName port client =     E.bracket open close $ \sock -> do-        recv <- mkRecvTCP defaultSettings sock-        run' "http" serverName (sendTCP sock) recv client+        mysa <- getSocketName sock+        peersa <- getPeerName sock+        recv <- mkRecvTCP Server.defaultSettings sock+        run' "http" serverName (sendTCP sock) recv mysa peersa client   where-    open = openTCP serverName port+    open = openTCP (settingsAddrInfoFlags defaultSettings) serverName port  run'     :: ByteString     -> HostName     -> (ByteString -> IO ())     -> IO ByteString+    -> SockAddr+    -> SockAddr     -> Client a     -> IO a-run' schm serverName send recv client =+run' schm serverName send recv mysa peersa client =     E.bracket-        (allocConfigForClient send recv)+        (allocConfigForClient send recv mysa peersa)         freeConfigForClient         (\conf -> H2Client.run cliconf conf client)   where@@ -83,18 +102,18 @@             , cacheLimit = 20             } -openTCP :: HostName -> PortNumber -> IO Socket-openTCP h p = do-    ai <- makeAddrInfo h p+openTCP :: [AddrInfoFlag] -> HostName -> PortNumber -> IO Socket+openTCP flags h p = do+    ai <- makeAddrInfo flags h p     sock <- openSocket ai     connect sock $ addrAddress ai     return sock -makeAddrInfo :: HostName -> PortNumber -> IO AddrInfo-makeAddrInfo nh p = do+makeAddrInfo :: [AddrInfoFlag] -> HostName -> PortNumber -> IO AddrInfo+makeAddrInfo flags nh p = do     let hints =             defaultHints-                { addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_NUMERICSERV]+                { addrFlags = flags                 , addrSocketType = Stream                 }     let np = show p@@ -103,33 +122,42 @@ ----------------------------------------------------------------  getClientParams-    :: HostName+    :: Settings+    -> HostName     -> ByteString     -- ^ ALPN-    -> Bool-    -- ^ Checking server certificates     -> ClientParams-getClientParams serverName alpn validate =+getClientParams Settings{..} serverName alpn =     (defaultParamsClient serverName "")         { clientSupported = supported         , clientWantSessionResume = Nothing         , clientUseServerNameIndication = True         , clientShared = shared         , clientHooks = hooks+        , clientDebug = debug         }   where     shared =         def             { sharedValidationCache = validateCache+            , sharedCAStore = settingsCAStore             }     supported = strongSupported     hooks =         def             { onSuggestALPN = return $ Just [alpn]+            , onServerCertificate = validateCert             }     validateCache-        | validate = def+        | settingsValidateCert = def         | otherwise =             ValidationCache                 (\_ _ _ -> return ValidationCachePass)                 (\_ _ _ -> return ())+    validateCert+        | settingsValidateCert = validateDefault+        | otherwise = \_ _ _ _ -> return []+    debug =+        def+            { debugKeyLogger = settingsKeyLogger+            }

@@ -0,0 +1,34 @@+module Network.HTTP2.TLS.Client.Settings where++import Data.X509.CertificateStore (CertificateStore)+import Network.Socket++-- Client settings type.+data Settings = Settings+    { settingsKeyLogger :: String -> IO ()+    -- ^ Key logger+    --+    -- Applications may wish to set this depending on the SSLKEYLOGFILE environment variable. Default is do nothing.+    , settingsValidateCert :: Bool+    -- ^ Should we validate TLS certificates?+    --+    -- >>> settingsValidateCert defaultSettings+    -- True+    , settingsCAStore :: CertificateStore+    -- ^ Certificate store used for validation. The default is 'mempty'.+    , settingsAddrInfoFlags :: [AddrInfoFlag]+    -- ^ Flags that control the querying behaviour of @getAddrInfo@.+    --+    -- >>> settingsAddrInfoFlags defaultSettings+    -- []+    }++-- | Default settings.+defaultSettings :: Settings+defaultSettings =+    Settings+        { settingsKeyLogger = \_ -> return ()+        , settingsValidateCert = True+        , settingsCAStore = mempty+        , settingsAddrInfoFlags = []+        }

@@ -9,14 +9,21 @@     Config (..),     defaultPositionReadMaker,  )+import Network.Socket (SockAddr) import Network.Socket.BufferPool import qualified System.TimeManager as T -import Network.HTTP2.TLS.Settings+import Network.HTTP2.TLS.Server.Settings  allocConfigForServer-    :: Settings -> T.Manager -> (ByteString -> IO ()) -> IO ByteString -> IO Config-allocConfigForServer Settings{..} mgr send recv = do+    :: Settings+    -> T.Manager+    -> (ByteString -> IO ())+    -> IO ByteString+    -> SockAddr+    -> SockAddr+    -> IO Config+allocConfigForServer Settings{..} mgr send recv mysa peersa = do     buf <- mallocBytes settingsSendBufferSize     recvN <- makeRecvN "" recv     let config =@@ -27,6 +34,8 @@                 , confReadN = recvN                 , confPositionReadMaker = defaultPositionReadMaker                 , confTimeoutManager = mgr+                , confMySockAddr = mysa+                , confPeerSockAddr = peersa                 }     return config @@ -34,9 +43,9 @@ freeConfigForServer :: Config -> IO () freeConfigForServer conf = free $ confWriteBuffer conf --allocConfigForClient :: (ByteString -> IO ()) -> IO ByteString -> IO Config-allocConfigForClient send recv = do+allocConfigForClient+    :: (ByteString -> IO ()) -> IO ByteString -> SockAddr -> SockAddr -> IO Config+allocConfigForClient send recv mysa peersa = do     let wbufsiz = 4096 -- fixme     buf <- mallocBytes wbufsiz     recvN <- makeRecvN "" recv@@ -51,6 +60,8 @@                 , confReadN = recvN                 , confPositionReadMaker = defaultPositionReadMaker                 , confTimeoutManager = mgr+                , confMySockAddr = mysa+                , confPeerSockAddr = peersa                 }     return config 

@@ -16,7 +16,7 @@ import qualified System.TimeManager as T import qualified UnliftIO.Exception as E -import Network.HTTP2.TLS.Settings+import Network.HTTP2.TLS.Server.Settings  ---------------------------------------------------------------- @@ -27,7 +27,7 @@  mkRecvTCP :: Settings -> Socket -> IO (IO ByteString) mkRecvTCP Settings{..} sock = do-    pool <- newBufferPool settingReadBufferLowerLimit settingReadBufferSize+    pool <- newBufferPool settingsReadBufferLowerLimit settingsReadBufferSize     return $ receive sock pool  sendTCP :: Socket -> ByteString -> IO ()@@ -46,11 +46,13 @@     -- ^ Sending many.     , recv :: IO ByteString     -- ^ Receiving.+    , mySockAddr :: SockAddr+    , peerSockAddr :: SockAddr     }  timeoutIOBackend :: T.Handle -> Settings -> IOBackend -> IOBackend timeoutIOBackend th Settings{..} IOBackend{..} =-    IOBackend send' sendMany' recv'+    IOBackend send' sendMany' recv' mySockAddr peerSockAddr   where     send' bs = send bs >> T.tickle th     sendMany' bss = sendMany bss >> T.tickle th@@ -59,22 +61,31 @@         when (BS.length bs > settingsSlowlorisSize) $ T.tickle th         return bs -tlsIOBackend :: Context -> IOBackend-tlsIOBackend ctx =-    IOBackend-        { send = sendTLS ctx-        , sendMany = sendManyTLS ctx-        , recv = recvTLS ctx-        }+tlsIOBackend :: Context -> Socket -> IO IOBackend+tlsIOBackend ctx sock = do+    mysa <- getSocketName sock+    peersa <- getPeerName sock+    return $+        IOBackend+            { send = sendTLS ctx+            , sendMany = sendManyTLS ctx+            , recv = recvTLS ctx+            , mySockAddr = mysa+            , peerSockAddr = peersa+            }  tcpIOBackend :: Settings -> Socket -> IO IOBackend tcpIOBackend settings sock = do     recv' <- mkRecvTCP settings sock+    mysa <- getSocketName sock+    peersa <- getPeerName sock     return $         IOBackend             { send = void . NSB.send sock             , sendMany = \_ -> return ()             , recv = recv'+            , mySockAddr = mysa+            , peerSockAddr = peersa             }  ----------------------------------------------------------------@@ -85,6 +96,7 @@ sendManyTLS :: Context -> [ByteString] -> IO () sendManyTLS ctx = sendData ctx . LBS.fromChunks +{- FOURMOLU_DISABLE -} -- TLS version of recv (decrypting) without a cache. recvTLS :: Context -> IO ByteString recvTLS ctx = E.handle onEOF $ recvData ctx@@ -97,6 +109,7 @@ #endif         | Just ioe <- E.fromException e, isEOFError ioe = return ""         | otherwise = E.throwIO e+{- FOURMOLU_ENABLE -}  ---------------------------------------------------------------- 

@@ -1,5 +1,17 @@+{-# LANGUAGE CPP #-}+ module Network.HTTP2.TLS.Internal (     module Network.HTTP2.TLS.IO,+    gclose, ) where +import Network.Socket+ import Network.HTTP2.TLS.IO++gclose :: Socket -> IO ()+#if MIN_VERSION_network(3,1,1)+gclose sock = gracefulClose sock 5000+#else+gclose = close+#endif

@@ -16,14 +16,17 @@     settingsTimeout,     settingsSendBufferSize,     settingsSlowlorisSize,-    settingReadBufferSize,-    settingReadBufferLowerLimit,+    settingsReadBufferSize,+    settingsReadBufferLowerLimit,+    settingsKeyLogger,      -- * IO backend     IOBackend,     send,     sendMany,     recv,+    mySockAddr,+    peerSockAddr, ) where  import Data.ByteString (ByteString)@@ -41,7 +44,7 @@  import Network.HTTP2.TLS.Config import Network.HTTP2.TLS.IO-import Network.HTTP2.TLS.Settings+import Network.HTTP2.TLS.Server.Settings import Network.HTTP2.TLS.Supported  -- | Running a TLS client.@@ -61,10 +64,10 @@         backend <- mkBackend settings sock         E.bracket (contextNew backend params) bye $ \ctx -> do             handshake ctx-            let iobackend = timeoutIOBackend th settings $ tlsIOBackend ctx+            iobackend <- timeoutIOBackend th settings <$> tlsIOBackend ctx sock             action mgr iobackend   where-    params = getServerParams creds alpn+    params = getServerParams creds alpn settingsKeyLogger  -- | Running an HTTP\/2 client over TLS (over TCP). --   ALPN is "h2".@@ -83,7 +86,7 @@ run' :: Settings -> Server -> T.Manager -> IOBackend -> IO () run' settings server mgr IOBackend{..} =     E.bracket-        (allocConfigForServer settings mgr send recv)+        (allocConfigForServer settings mgr send recv mySockAddr peerSockAddr)         freeConfigForServer         (\conf -> H2Server.run conf server) @@ -92,12 +95,14 @@ getServerParams     :: Credentials     -> ByteString+    -> (String -> IO ())     -> ServerParams-getServerParams creds alpn =+getServerParams creds alpn keyLogger =     def         { serverSupported = supported         , serverShared = shared         , serverHooks = hooks+        , serverDebug = debug         }   where     shared =@@ -109,6 +114,10 @@     hooks =         def             { onALPNClientSuggest = Just $ selectALPN alpn+            }+    debug =+        def+            { debugKeyLogger = keyLogger             }  selectALPN :: ByteString -> [ByteString] -> IO ByteString

@@ -0,0 +1,48 @@+module Network.HTTP2.TLS.Server.Settings where++-- Server settings type.+data Settings = Settings+    { settingsTimeout :: Int+    -- ^ Timeout in seconds. (All)+    --+    -- >>> settingsTimeout defaultSettings+    -- 30+    , settingsSendBufferSize :: Int+    -- ^ Send buffer size. (H2 and H2c)+    --+    -- >>> settingsSendBufferSize defaultSettings+    -- 4096+    , settingsSlowlorisSize :: Int+    -- ^ If the size of receiving data is less than or equal,+    --   the timeout is not reset.+    --   (All)+    --+    -- >>> settingsSlowlorisSize defaultSettings+    -- 50+    , settingsReadBufferSize :: Int+    -- ^ When the size of a read buffer is lower than this limit, the buffer is thrown awany (and is eventually freed). Then a new buffer is allocated. (All)+    --+    -- >>> settingsReadBufferSize defaultSettings+    -- 16384+    , settingsReadBufferLowerLimit :: Int+    -- ^  The allocation size for a read buffer.  (All)+    --+    -- >>> settingsReadBufferLowerLimit defaultSettings+    -- 2048+    , settingsKeyLogger :: String -> IO ()+    -- ^ Key logger (defaults to none)+    --+    -- Applications may wish to set this depending on the SSLKEYLOGFILE environment variable. The default is do nothing.+    }++-- | Default settings.+defaultSettings :: Settings+defaultSettings =+    Settings+        { settingsTimeout = 30+        , settingsSendBufferSize = 4096+        , settingsSlowlorisSize = 50+        , settingsReadBufferSize = 16384+        , settingsReadBufferLowerLimit = 2048+        , settingsKeyLogger = \_ -> return ()+        }

@@ -1,31 +0,0 @@-module Network.HTTP2.TLS.Settings where---- Settings type.-data Settings = Settings-    { settingsTimeout :: Int-    -- ^ Timeout in seconds. (All)-    , settingsSendBufferSize :: Int-    -- ^ Send buffer size. (H2 and H2c)-    , settingsSlowlorisSize :: Int-    -- ^ If the size of receiving data is less than or equal,-    --   the timeout is not reset.-    --   (All)-    , settingReadBufferSize :: Int-    -- ^ When the size of a read buffer is lower than this limit, the buffer is thrown awany (and is eventually freed). Then a new buffer is allocated. (All)-    , settingReadBufferLowerLimit :: Int-    -- ^  The allocation size for a read buffer.  (All)-    } deriving (Eq, Show)---- | Default settings.------ >>> defaultSettings--- Settings {settingsTimeout = 30, settingsSendBufferSize = 4096, settingsSlowlorisSize = 50, settingReadBufferSize = 16384, settingReadBufferLowerLimit = 2048}-defaultSettings :: Settings-defaultSettings =-    Settings-        { settingsTimeout = 30-        , settingsSendBufferSize = 4096-        , settingsSlowlorisSize = 50-        , settingReadBufferSize = 16384-        , settingReadBufferLowerLimit = 2048-        }

@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               http2-tls-version:            0.0.1+version:            0.1.0 license:            BSD3 license-file:       LICENSE maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>@@ -24,9 +24,10 @@         Network.HTTP2.TLS.Server      other-modules:+        Network.HTTP2.TLS.Client.Settings         Network.HTTP2.TLS.Config         Network.HTTP2.TLS.IO-        Network.HTTP2.TLS.Settings+        Network.HTTP2.TLS.Server.Settings         Network.HTTP2.TLS.Supported      default-language:   Haskell2010@@ -35,8 +36,10 @@     build-depends:         base >=4.9 && <5,         bytestring,+        crypton-x509-store,+        crypton-x509-validation,         data-default-class,-        http2,+        http2 >= 4.2.0,         network,         network-run >=0.2.6,         recv,