timeout for handshake

yesodweb · Nov 5, 2024 · 2baca8b · 2baca8b
1 parent e901414
commit 2baca8b
Showing 1 changed file with 9 additions and 4 deletions.
diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs
@@ -350,7 +350,7 @@ httpOverTls
     -> S.ByteString
     -> params
     -> IO (Connection, Transport)
-httpOverTls TLSSettings{..} _set s bs0 params =
+httpOverTls TLSSettings{..} set s bs0 params =
     makeConn `onException` close s
   where
     makeConn = do
@@ -359,9 +359,14 @@ httpOverTls TLSSettings{..} _set s bs0 params =
         let recvN = wrappedRecvN rawRecvN
         ctx <- TLS.contextNew (backend recvN) params
         TLS.contextHookSetLogging ctx tlsLogging
-        TLS.handshake ctx
-        mysa <- getSocketName s
-        attachConn mysa ctx
+        let tm = settingsTimeout set * 1000000
+        mconn <- timeout tm $ do
+            TLS.handshake ctx
+            mysa <- getSocketName s
+            attachConn mysa ctx
+        case mconn of
+          Nothing -> throwIO IncompleteHeaders
+          Just conn -> return conn
     wrappedRecvN recvN n = handleAny (const mempty) $ recvN n
     backend recvN =
         TLS.Backend