Merge PR #1007

yesodweb · Sep 24, 2024 · ec5e017 · ec5e017
2 parents 266f238 + 12e40c9
commit ec5e017
Show file tree

Hide file tree

Showing 6 changed files with 32 additions and 14 deletions.
diff --git a/warp-tls/ChangeLog.md b/warp-tls/ChangeLog.md
@@ -1,5 +1,10 @@
 # ChangeLog
 
+## 3.4.7
+
+* Expose `attachConn` to use post-handshake TLS connection.
+  [#1007](https://github.com/yesodweb/wai/pull/1007)
+
 ## 3.4.6
 
 * Preparing for tls v2.1

diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs
@@ -50,6 +50,9 @@ module Network.Wai.Handler.WarpTLS (
 
     -- * Exception
     WarpTLSException (..),
+
+    -- * Low-level
+    attachConn
 ) where
 
 import Control.Applicative ((<|>))
@@ -357,14 +360,9 @@ httpOverTls TLSSettings{..} _set s bs0 params =
         ctx <- TLS.contextNew (backend recvN) params
         TLS.contextHookSetLogging ctx tlsLogging
         TLS.handshake ctx
-        h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx
-        isH2 <- I.newIORef h2
-        writeBuffer <- createWriteBuffer 16384
-        writeBufferRef <- I.newIORef writeBuffer
-        -- Creating a cache for leftover input data.
-        tls <- getTLSinfo ctx
         mysa <- getSocketName s
-        return (conn ctx writeBufferRef isH2 mysa, tls)
+        attachConn mysa ctx
+    wrappedRecvN recvN n = handleAny (const mempty) $ recvN n
     backend recvN =
         TLS.Backend
             { TLS.backendFlush = return ()
@@ -386,7 +384,20 @@ httpOverTls TLSSettings{..} _set s bs0 params =
             )
             throwIO
             $ sendAll sock bs
-    conn ctx writeBufferRef isH2 mysa =
+
+-- | Get "Connection" and "Transport" for a TLS connection that is already did the handshake.
+-- @since 3.4.7
+attachConn :: SockAddr -> TLS.Context -> IO (Connection, Transport)
+attachConn mysa ctx = do
+    h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx
+    isH2 <- I.newIORef h2
+    writeBuffer <- createWriteBuffer 16384
+    writeBufferRef <- I.newIORef writeBuffer
+    -- Creating a cache for leftover input data.
+    tls <- getTLSinfo ctx
+    return (conn writeBufferRef isH2, tls)
+  where
+    conn writeBufferRef isH2 =
         Connection
             { connSendMany = TLS.sendData ctx . L.fromChunks
             , connSendAll = sendall
@@ -434,10 +445,6 @@ httpOverTls TLSSettings{..} _set s bs0 params =
                 (const (return ()))
                 (TLS.bye ctx)
 
-    wrappedRecvN recvN n = handleAny handler $ recvN n
-    handler :: SomeException -> IO S.ByteString
-    handler _ = return ""
-
 getTLSinfo :: TLS.Context -> IO Transport
 getTLSinfo ctx = do
     proto <- TLS.getNegotiatedProtocol ctx

diff --git a/warp-tls/warp-tls.cabal b/warp-tls/warp-tls.cabal
@@ -1,5 +1,5 @@
 Name:                warp-tls
-Version:             3.4.6
+Version:             3.4.7
 Synopsis:            HTTP over TLS support for Warp via the TLS package
 License:             MIT
 License-file:        LICENSE

diff --git a/warp/ChangeLog.md b/warp/ChangeLog.md
@@ -1,5 +1,10 @@
 # ChangeLog for warp
 
+## 3.4.2
+
+* serveConnection is re-exported from the Internal module.
+  [#1007](https://github.com/yesodweb/wai/pull/1007)
+
 ## 3.4.1
 
 * Using time-manager v0.1.0, and auto-update v0.2.0.

diff --git a/warp/Network/Wai/Handler/Warp/Internal.hs b/warp/Network/Wai/Handler/Warp/Internal.hs
@@ -86,6 +86,7 @@ module Network.Wai.Handler.Warp.Internal (
     -- * Misc
     http2server,
     withII,
+    serveConnection,
     pReadMaker,
 ) where
 

diff --git a/warp/warp.cabal b/warp/warp.cabal
@@ -1,6 +1,6 @@
 cabal-version:      >=1.10
 name:               warp
-version:            3.4.1
+version:            3.4.2
 license:            MIT
 license-file:       LICENSE
 maintainer:         [email protected]