packages feed

http2-tls (empty) → 0.0.0

raw patch · 9 files changed

+551/−0 lines, 9 filesdep +basedep +bytestringdep +data-default-class

Dependencies added: base, bytestring, data-default-class, http2, network, network-run, recv, time-manager, tls, unliftio

Files

+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2023, IIJ Innovation Institute Inc.+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 the copyright holders nor the names of its+    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.
+ Network/HTTP2/TLS/Client.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Running an HTTP\/2 client over TLS.+module Network.HTTP2.TLS.Client (+    -- * Runners+    run,+    runH2C,+    Client,+    HostName,+    PortNumber,+    runTLS,+) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8+import Data.Default.Class (def)+import Network.HTTP2.Client (+    Client,+    ClientConfig (..),+ )+import qualified Network.HTTP2.Client as H2Client+import Network.Socket+import Network.TLS hiding (HostName)+import qualified UnliftIO.Exception as E++import Network.HTTP2.TLS.Config+import Network.HTTP2.TLS.IO+import Network.HTTP2.TLS.Settings+import Network.HTTP2.TLS.Supported++----------------------------------------------------------------++-- | Running a TLS client.+runTLS+    :: HostName+    -> PortNumber+    -> ByteString+    -- ^ ALPN+    -> (Context -> IO a)+    -> IO a+runTLS serverName port alpn action =+    E.bracket open close $ \sock -> do+        E.bracket (contextNew sock params) bye $ \ctx -> do+            handshake ctx+            action ctx+  where+    open = openTCP serverName port+    params = getClientParams serverName alpn False++-- | 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++-- | 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+  where+    open = openTCP serverName port++run'+    :: ByteString+    -> HostName+    -> (ByteString -> IO ())+    -> IO ByteString+    -> Client a+    -> IO a+run' schm serverName send recv client =+    E.bracket+        (allocConfigForClient send recv)+        freeConfigForClient+        (\conf -> H2Client.run cliconf conf client)+  where+    cliconf =+        ClientConfig+            { scheme = schm+            , authority = C8.pack serverName+            , cacheLimit = 20+            }++openTCP :: HostName -> PortNumber -> IO Socket+openTCP h p = do+    ai <- makeAddrInfo h p+    sock <- openSocket ai+    connect sock $ addrAddress ai+    return sock++makeAddrInfo :: HostName -> PortNumber -> IO AddrInfo+makeAddrInfo nh p = do+    let hints =+            defaultHints+                { addrFlags = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_NUMERICSERV]+                , addrSocketType = Stream+                }+    let np = show p+    head <$> getAddrInfo (Just hints) (Just nh) (Just np)++----------------------------------------------------------------++getClientParams+    :: HostName+    -> ByteString+    -- ^ ALPN+    -> Bool+    -- ^ Checking server certificates+    -> ClientParams+getClientParams serverName alpn validate =+    (defaultParamsClient serverName "")+        { clientSupported = supported+        , clientWantSessionResume = Nothing+        , clientUseServerNameIndication = True+        , clientShared = shared+        , clientHooks = hooks+        }+  where+    shared =+        def+            { sharedValidationCache = validateCache+            }+    supported = strongSupported+    hooks =+        def+            { onSuggestALPN = return $ Just [alpn]+            }+    validateCache+        | validate = def+        | otherwise =+            ValidationCache+                (\_ _ _ -> return ValidationCachePass)+                (\_ _ _ -> return ())
+ Network/HTTP2/TLS/Config.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.TLS.Config where++import Data.ByteString (ByteString)+import Foreign.Marshal.Alloc (free, mallocBytes)+import Network.HTTP2.Client (+    Config (..),+    defaultPositionReadMaker,+ )+import Network.Socket.BufferPool+import qualified System.TimeManager as T++import Network.HTTP2.TLS.Settings++allocConfigForServer+    :: Settings -> T.Manager -> (ByteString -> IO ()) -> IO ByteString -> IO Config+allocConfigForServer Settings{..} mgr send recv = do+    buf <- mallocBytes settingsSendBufferSize+    recvN <- makeRecvN "" recv+    let config =+            Config+                { confWriteBuffer = buf+                , confBufferSize = settingsSendBufferSize+                , confSendAll = send+                , confReadN = recvN+                , confPositionReadMaker = defaultPositionReadMaker+                , confTimeoutManager = mgr+                }+    return config++-- | Deallocating the resource of the simple configuration.+freeConfigForServer :: Config -> IO ()+freeConfigForServer conf = free $ confWriteBuffer conf+++allocConfigForClient :: (ByteString -> IO ()) -> IO ByteString -> IO Config+allocConfigForClient send recv = do+    let wbufsiz = 4096 -- fixme+    buf <- mallocBytes wbufsiz+    recvN <- makeRecvN "" recv+    -- A global manager does not exist.+    -- So, a timeout manager is created per connection.+    mgr <- T.initialize 30000000 -- fixme+    let config =+            Config+                { confWriteBuffer = buf+                , confBufferSize = wbufsiz+                , confSendAll = send+                , confReadN = recvN+                , confPositionReadMaker = defaultPositionReadMaker+                , confTimeoutManager = mgr+                }+    return config++-- | Deallocating the resource of the simple configuration.+freeConfigForClient :: Config -> IO ()+freeConfigForClient Config{..} = do+    free confWriteBuffer+    T.killManager confTimeoutManager
+ Network/HTTP2/TLS/IO.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.TLS.IO where++import Control.Monad (void, when)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Network.Socket+import Network.Socket.BufferPool+import qualified Network.Socket.ByteString as NSB+import Network.TLS hiding (HostName)+import System.IO.Error (isEOFError)+import qualified System.TimeManager as T+import qualified UnliftIO.Exception as E++import Network.HTTP2.TLS.Settings++----------------------------------------------------------------++-- HTTP2: confReadN == recvTLS+-- TLS:   recvData  == contextRecv == backendRecv++----------------------------------------------------------------++mkRecvTCP :: Settings -> Socket -> IO (IO ByteString)+mkRecvTCP Settings{..} sock = do+    pool <- newBufferPool settingReadBufferLowerLimit settingReadBufferSize+    return $ receive sock pool++sendTCP :: Socket -> ByteString -> IO ()+sendTCP sock = NSB.sendAll sock++----------------------------------------------------------------++-- | Sending and receiving functions.+--   Tiemout is reset when they return.+--   One exception is the slowloris attach prevention.+--   See 'settingsSlowlorisSize'.+data IOBackend = IOBackend+    { send :: ByteString -> IO ()+    -- ^ Sending.+    , sendMany :: [ByteString] -> IO ()+    -- ^ Sending many.+    , recv :: IO ByteString+    -- ^ Receiving.+    }++timeoutIOBackend :: T.Handle -> Settings -> IOBackend -> IOBackend+timeoutIOBackend th Settings{..} IOBackend{..} =+    IOBackend send' sendMany' recv'+  where+    send' bs = send bs >> T.tickle th+    sendMany' bss = sendMany bss >> T.tickle th+    recv' = do+        bs <- recv+        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+        }++tcpIOBackend :: Settings -> Socket -> IO IOBackend+tcpIOBackend settings sock = do+    recv' <- mkRecvTCP settings sock+    return $+        IOBackend+            { send = void . NSB.send sock+            , sendMany = \_ -> return ()+            , recv = recv'+            }++----------------------------------------------------------------++sendTLS :: Context -> ByteString -> IO ()+sendTLS ctx = sendData ctx . LBS.fromStrict++sendManyTLS :: Context -> [ByteString] -> IO ()+sendManyTLS ctx = sendData ctx . LBS.fromChunks++-- TLS version of recv (decrypting) without a cache.+recvTLS :: Context -> IO ByteString+recvTLS ctx = E.handle onEOF $ recvData ctx+  where+    onEOF e+        | Just Error_EOF <- E.fromException e = return ""+        | Just ioe <- E.fromException e, isEOFError ioe = return ""+        | otherwise = E.throwIO e++----------------------------------------------------------------++mkBackend :: Settings -> Socket -> IO Backend+mkBackend settings sock = do+    let send' = sendTCP sock+    recv' <- mkRecvTCP settings sock+    recvN <- makeRecvN "" recv'+    return+        Backend+            { backendFlush = return ()+            , backendClose =+                gracefulClose sock 5000 `E.catch` \(E.SomeException _) -> return ()+            , backendSend = send'+            , backendRecv = recvN+            }
+ Network/HTTP2/TLS/Internal.hs view
@@ -0,0 +1,5 @@+module Network.HTTP2.TLS.Internal (+    module Network.HTTP2.TLS.IO,+) where++import Network.HTTP2.TLS.IO
+ Network/HTTP2/TLS/Server.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.TLS.Server (+    -- * Runners+    run,+    runH2C,+    Server,+    HostName,+    PortNumber,+    runTLS,++    -- * Settings+    Settings,+    defaultSettings,+    settingsTimeout,+    settingsSendBufferSize,+    settingsSlowlorisSize,+    settingReadBufferSize,+    settingReadBufferLowerLimit,++    -- * IO backend+    IOBackend,+    send,+    sendMany,+    recv,+) where++import Data.ByteString (ByteString)+import Data.Default.Class (def)+import Network.HTTP2.Server (Server)+import qualified Network.HTTP2.Server as H2Server+import Network.Run.TCP.Timeout+import Network.Socket (+    HostName,+    PortNumber,+ )+import Network.TLS hiding (HostName)+import qualified System.TimeManager as T+import qualified UnliftIO.Exception as E++import Network.HTTP2.TLS.Config+import Network.HTTP2.TLS.IO+import Network.HTTP2.TLS.Settings+import Network.HTTP2.TLS.Supported++-- | Running a TLS client.+--   'IOBackend' provides sending and receiving functions+--   with timeout based on 'Settings'.+runTLS+    :: Settings+    -> Credentials+    -> HostName+    -> PortNumber+    -> ByteString+    -- ^ ALPN+    -> (T.Manager -> IOBackend -> IO a)+    -> IO a+runTLS settings@Settings{..} creds host port alpn action =+    runTCPServer settingsTimeout (Just host) (show port) $ \mgr th sock -> do+        backend <- mkBackend settings sock+        E.bracket (contextNew backend params) bye $ \ctx -> do+            handshake ctx+            let iobackend = timeoutIOBackend th settings $ tlsIOBackend ctx+            action mgr iobackend+  where+    params = getServerParams creds alpn++-- | Running an HTTP\/2 client over TLS (over TCP).+--   ALPN is "h2".+run :: Settings -> Credentials -> HostName -> PortNumber -> Server -> IO ()+run settings creds host port server =+    runTLS settings creds host port "h2" $ run' settings server++-- | Running an HTTP\/2 client over TCP.+runH2C :: Settings -> HostName -> PortNumber -> Server -> IO ()+runH2C settings@Settings{..} host port server =+    runTCPServer settingsTimeout (Just host) (show port) $ \mgr th sock -> do+        iobackend0 <- tcpIOBackend settings sock+        let iobackend = timeoutIOBackend th settings iobackend0+        run' settings server mgr iobackend++run' :: Settings -> Server -> T.Manager -> IOBackend -> IO ()+run' settings server mgr IOBackend{..} =+    E.bracket+        (allocConfigForServer settings mgr send recv)+        freeConfigForServer+        (\conf -> H2Server.run conf server)++----------------------------------------------------------------++getServerParams+    :: Credentials+    -> ByteString+    -> ServerParams+getServerParams creds alpn =+    def+        { serverSupported = supported+        , serverShared = shared+        , serverHooks = hooks+        }+  where+    shared =+        def+            { sharedCredentials = creds+            --            , sharedSessionManager = undefined+            }+    supported = strongSupported+    hooks =+        def+            { onALPNClientSuggest = Just $ selectALPN alpn+            }++selectALPN :: ByteString -> [ByteString] -> IO ByteString+selectALPN key xs+    | key `elem` xs = return key+    | otherwise = return ""
+ Network/HTTP2/TLS/Settings.hs view
@@ -0,0 +1,31 @@+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+        }
+ Network/HTTP2/TLS/Supported.hs view
@@ -0,0 +1,18 @@+module Network.HTTP2.TLS.Supported where++import Data.Default.Class (def)+import Network.TLS hiding (HostName)+import Network.TLS.Extra++strongSupported :: Supported+strongSupported =+    def -- TLS.Supported+        { supportedVersions = [TLS13, TLS12]+        , supportedCiphers = ciphersuite_strong+        , supportedCompressions = [nullCompression]+        , supportedSecureRenegotiation = True+        , supportedClientInitiatedRenegotiation = False+        , supportedSession = True+        , supportedFallbackScsv = True+        , supportedGroups = [X25519, P256, P384]+        }
+ http2-tls.cabal view
@@ -0,0 +1,45 @@+cabal-version:      >=1.10+name:               http2-tls+version:            0.0.0+license:            BSD3+license-file:       LICENSE+maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>+author:             Kazu Yamamoto <kazu@iij.ad.jp>+homepage:           https://github.com/kazu-yamamoto/http2-tls+synopsis:           Library for HTTP/2 over TLS+description:+    Using the HTTP/2 library over TLS++category:           Network+build-type:         Simple++source-repository head+    type:     git+    location: https://github.com/kazu-yamamoto/http2-tls++library+    exposed-modules:+        Network.HTTP2.TLS.Client+        Network.HTTP2.TLS.Internal+        Network.HTTP2.TLS.Server++    other-modules:+        Network.HTTP2.TLS.Config+        Network.HTTP2.TLS.IO+        Network.HTTP2.TLS.Settings+        Network.HTTP2.TLS.Supported++    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall+    build-depends:+        base >=4.9 && <5,+        bytestring,+        data-default-class,+        http2,+        network,+        network-run >=0.2.6,+        recv,+        time-manager,+        tls,+        unliftio