Win32-network tests

Make sure IOException are re-thrown in the main thread in the following tests: - Async.Handle.reads and writes - Async.Socket.send and recv
IntersectMBO · Feb 18, 2020 · 2faa36e · 2faa36e
1 parent 36ec4c4
commit 2faa36e
Show file tree

Hide file tree

Showing 2 changed files with 21 additions and 17 deletions.
diff --git a/Win32-network/test/Test/Async/Handle.hs b/Win32-network/test/Test/Async/Handle.hs
@@ -476,8 +476,10 @@ prop_async_reads_and_writes (LargeNonEmptyBS bsIn bufSizeIn) (LargeNonEmptyBS bs
       clientVar <- newEmptyMVar
       serverVar <- newEmptyMVar
 
+      mainThread <- myThreadId
+
       -- fork a server
-      _ <- forkIO $
+      _ <- forkIO $ handle (\e -> throwTo mainThread e >> ioError e) $
         bracket
             (createNamedPipe pname
                              (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED)
@@ -502,7 +504,7 @@ prop_async_reads_and_writes (LargeNonEmptyBS bsIn bufSizeIn) (LargeNonEmptyBS bs
 
 
       -- fork a client
-      _ <- forkIO $ do
+      _ <- forkIO $ handle (\e -> throwTo mainThread e >> ioError e) $ do
         takeMVar syncVarStart
         bracket
           (createFile pname

diff --git a/Win32-network/test/Test/Async/Socket.hs b/Win32-network/test/Test/Async/Socket.hs
@@ -173,21 +173,23 @@ prop_send_recv (LargeNonEmptyBS bs _size) =
           syncVar <- newEmptyMVar
           Async.associateWithIOCompletionPort (Right fd_in)  iocp
 
-          _ <- forkIO $ do
-            let addr = SockAddrInet 0 (Socket.tupleToHostAddress (127, 0, 0, 1))
-            Socket.bind fd_out addr
-            addr' <- Socket.getSocketName fd_out
-            Socket.listen fd_out 1024
-              `catch` \(e :: IOException) -> putStrLn ("listen errored: " ++ displayException e) >> throwIO e
-            putMVar syncVar addr'
-            (fd, _) <- Async.accept fd_out
-                        `catch` \(e :: IOException) -> putStrLn ("accept errored: " ++ displayException e) >> throwIO e
-
-            Async.associateWithIOCompletionPort (Right fd) iocp
-            bs' <- BL.toStrict <$> recvLen fd (BS.length bs)
-            putMVar v bs'
-
-          _ <- forkIO $ do
+          mainThread <- myThreadId
+
+          _ <- forkIO $ handle (\e -> throwTo mainThread e >> ioError e) $ do
+              let addr = SockAddrInet 0 (Socket.tupleToHostAddress (127, 0, 0, 1))
+              Socket.bind fd_out addr
+              addr' <- Socket.getSocketName fd_out
+              Socket.listen fd_out 1024
+                `catch` \(e :: IOException) -> putStrLn ("listen errored: " ++ displayException e) >> throwIO e
+              putMVar syncVar addr'
+              (fd, _) <- Async.accept fd_out
+                          `catch` \(e :: IOException) -> putStrLn ("accept errored: " ++ displayException e) >> throwIO e
+
+              Async.associateWithIOCompletionPort (Right fd) iocp
+              bs' <- BL.toStrict <$> recvLen fd (BS.length bs)
+              putMVar v bs'
+
+          _ <- forkIO $ handle (\e -> throwTo mainThread e >> ioError e) $ do
             -- wait for the other end to start listening
             addr' <- takeMVar syncVar
             Socket.connect fd_in addr'