From 76f3e078457416b767bec6eab8413bb900eda22e Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 9 Aug 2023 16:01:00 -0400
Subject: [PATCH] Add reproducer

---
 Repro.hs | 40 ++++++++++++++++++++++++++++++++++++++++
 Test.hs  | 20 ++++++++++++++++++++
 run.sh   | 29 +++++++++++++++++++++++++++++
 3 files changed, 89 insertions(+)
 create mode 100644 Repro.hs
 create mode 100644 Test.hs
 create mode 100644 run.sh

diff --git a/Repro.hs b/Repro.hs
new file mode 100644
index 000000000..eae925d03
--- /dev/null
+++ b/Repro.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Network.Socket
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.HTTP.Types (status200)
+import Network.Wai.Handler.Warp.Internal
+import Data.ByteString.Builder (byteString)
+import Debug.Trace
+import Control.Concurrent
+import qualified Control.Exception as E
+
+main :: IO ()
+main = do
+  let settings =
+        defaultSettings { 
+          settingsOnClose = \_ -> msg "closed!",
+          settingsOnException = \_ e -> msg ("Exception: " ++ show e) >> E.throw e
+        }
+  runSettings settings app
+
+msg :: String -> IO ()
+msg s = traceEventIO s
+
+
+app :: Application
+app req respond = E.handle onErr $ do
+    connectionIsInactive req
+    msg "starting handler"
+    threadDelay $ 10*1000*1000
+    msg "handler responding..." 
+    x <- respond $ responseBuilder status200 [("Content-Type", "text/plain")] (byteString "Hello, world!")
+    msg "handler done" 
+    return x
+  where
+    onErr e =
+      msg ("Handler exception: " ++ show @E.SomeException e) >> E.throw e
+
diff --git a/Test.hs b/Test.hs
new file mode 100644
index 000000000..22d3f84b9
--- /dev/null
+++ b/Test.hs
@@ -0,0 +1,20 @@
+import Control.Concurrent
+import System.IO
+import Network.Socket as N
+
+main :: IO ()
+main = do
+    addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just "127.0.0.1") (Just "3000")
+    s <- N.openSocket addr
+    N.connect s (addrAddress addr)
+    putStrLn "Client connected"
+    hdl <- N.socketToHandle s ReadWriteMode
+    hPutStr hdl $ unlines
+        [ "GET / HTTP/1.1"
+        , ""
+        , ""
+        , ""
+        ]
+    threadDelay (100*1000)
+    putStrLn "Client closing"
+    N.close s
diff --git a/run.sh b/run.sh
new file mode 100644
index 000000000..351ee035f
--- /dev/null
+++ b/run.sh
@@ -0,0 +1,29 @@
+#!/usr/bin/env bash
+
+set -e
+
+GHC="$HOME/ghc/ghc-compare-3/_build/stage1/bin/ghc"
+#GHC="$HOME/ghcs-nix/ghcs/9.4.5/bin/ghc"
+
+cabal build -w $GHC warp --write-ghc-environment-file=always
+$GHC Repro.hs -threaded -debug
+$GHC Test.hs -threaded -debug
+
+run() {
+    echo "Starting server..."
+    ./Repro +RTS -N2 -v-au 2>&1 &
+    sleep 1
+
+    echo "Starting client..."
+    ./Test
+    echo "Client done"
+
+    sleep 15
+    echo "Killing server..."
+    kill -INT %1
+
+    echo "Done"
+    #nix run nixpkgs#haskellPackages.ghc-events -- show Repro.eventlog
+}
+
+run | nix shell nixpkgs#moreutils -c ts -i "%.S"