diff --git a/Network/HTTP2/TLS/Client.hs b/Network/HTTP2/TLS/Client.hs --- a/Network/HTTP2/TLS/Client.hs +++ b/Network/HTTP2/TLS/Client.hs @@ -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 + } diff --git a/Network/HTTP2/TLS/Client/Settings.hs b/Network/HTTP2/TLS/Client/Settings.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/TLS/Client/Settings.hs @@ -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 = [] + } diff --git a/Network/HTTP2/TLS/Config.hs b/Network/HTTP2/TLS/Config.hs --- a/Network/HTTP2/TLS/Config.hs +++ b/Network/HTTP2/TLS/Config.hs @@ -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 diff --git a/Network/HTTP2/TLS/IO.hs b/Network/HTTP2/TLS/IO.hs --- a/Network/HTTP2/TLS/IO.hs +++ b/Network/HTTP2/TLS/IO.hs @@ -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 -} ---------------------------------------------------------------- diff --git a/Network/HTTP2/TLS/Internal.hs b/Network/HTTP2/TLS/Internal.hs --- a/Network/HTTP2/TLS/Internal.hs +++ b/Network/HTTP2/TLS/Internal.hs @@ -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 diff --git a/Network/HTTP2/TLS/Server.hs b/Network/HTTP2/TLS/Server.hs --- a/Network/HTTP2/TLS/Server.hs +++ b/Network/HTTP2/TLS/Server.hs @@ -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 diff --git a/Network/HTTP2/TLS/Server/Settings.hs b/Network/HTTP2/TLS/Server/Settings.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/TLS/Server/Settings.hs @@ -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 () + } diff --git a/Network/HTTP2/TLS/Settings.hs b/Network/HTTP2/TLS/Settings.hs deleted file mode 100644 --- a/Network/HTTP2/TLS/Settings.hs +++ /dev/null @@ -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 - } 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.0.1 +version: 0.1.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -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,