Merge #1897

1897: Change how IOManager is handling exceptions r=dcoutts a=coot

With this patch `withIOManager` will rethrown the exception thrown when
`LPOVERLAPPED` was null.  This wasn't the case previously which was a mistake.

I also documented better (an experiment a bit more) with one particular case:
why we are not throwing exceptions when the `LPOVERLAPPED` is `NULL` and
`GetQueuedIoCompletionStatus` errored with `ERROR_INVALID_HANDLE`.  I can
reproduce this scenario when we close the iocp's `HANDLE`, but only in some
circumstances e.g. running the same test twice or more.  The first time
`dequeueCompletionPackets` exists cleanly (i.e. `GetQueuedIoCompletionStatus`
errors with `ERROR_ABANDONDED_WAIT_0`) and the next one errors with
`ERROR_INVALID_HANDLE`).  This behaviour is not documented in `MSDN`.

Also label the `IOManager` thread, which is useful for profiling with the
eventlog.

- withIOManager use IOException
- Removed withMaxSuccess from tests
- Label the IOManager thread


Co-authored-by: Marcin Szamotulski <[email protected]>

Author: iohk-bors[bot]

Win32-network/src/System/IOManager.hs

@@ -1,11 +1,15 @@
 {-# LANGUAGE CPP        #-}
 {-# LANGUAGE RankNTypes #-}
 
+-- we are exporting `Void` with constructors
+{-# OPTIONS_GHC -Wno-dodgy-exports #-}
+
 -- | A shim layer for `Win32-network`'s `IOManager`
 --
 module System.IOManager
   ( WithIOManager
   , IOManager (..)
+  , IOManagerError (..)
   , withIOManager
 
   -- * Deprecated API
@@ -18,6 +22,14 @@ module System.IOManager
 import System.Win32.Types (HANDLE)
 import qualified System.Win32.Async.IOManager as Win32.Async
 import Network.Socket (Socket)
+#else
+import Data.Void (Void)
+#endif
+
+#if defined(mingw32_HOST_OS)
+type IOManagerError = Win32.Async.IOManagerError
+#else
+type IOManagerError = Void
 #endif
 
 -- | This is public api to interact with the io manager; On Windows 'IOManager'
@@ -50,9 +62,17 @@ type AssociateWithIOCP = IOManager
 type WithIOManager = forall a. (IOManager -> IO a) -> IO a
 
 
--- | 'withIOManger' must be called only once at the top level.  We wrap the
--- 'associateWithIOCompletionPort' in a newtype wrapper since it will be
--- carried arround through the application.
+-- | 'withIOManager' allows to do asynchronous io on Windows hiding the
+-- differences between posix and Win32.
+--
+-- It starts an io manger thread, which should be only one running at a time, so
+-- the best place to call it is very close to the 'main' function and last for
+-- duration of the application.
+--
+-- Async 'IO' operatitions which are using the 'iocp' port should not leak
+-- out-side of 'withIOManager'.  They will be silently cancelled when
+-- 'withIOManager' exists.  In particular one should not return 'IOManager'
+-- from 'withIOManager'.
 --
 withIOManager :: WithIOManager
 #if defined(mingw32_HOST_OS)

Win32-network/src/System/Win32/Async/IOManager.hsc

@@ -15,7 +15,7 @@ module System.Win32.Async.IOManager
       IOCompletionPort
     , associateWithIOCompletionPort
     , withIOManager
-    , IOManagerError (..)
+    , IOManagerError
 
       -- * Low level IOCP interface
     , dequeueCompletionPackets
@@ -39,6 +39,7 @@ import Foreign.Ptr (Ptr, intPtrToPtr, nullPtr)
 import Foreign.StablePtr (deRefStablePtr, freeStablePtr)
 import Foreign.Marshal (alloca, free)
 import Foreign.Storable (Storable (..))
+import GHC.Conc (labelThread)
 
 import           Network.Socket (Socket)
 import qualified Network.Socket as Socket
@@ -140,23 +141,17 @@ withIOManager k =
             -- But note that 'closeIOCopletionPort' will terminate the io-manager
             -- thread (we cover this scenario in the 'test_closeIOCP' test).
             _ <-
-              forkOS
-                $ void $ dequeueCompletionPackets iocp
-                  `catch`
-                  \(e :: IOException) -> do
-                    -- throw IOExceptoin's back to the thread which started 'IOManager'
-                    throwTo tid (IOManagerError e)
-                    throwIO e
+              forkOS $
+                do
+                  myThreadId >>= flip labelThread "IOManager"
+                  void $ dequeueCompletionPackets iocp
+               `catch` \(e :: IOException) -> do
+                  -- throw IOExceptoin's back to the thread which started 'IOManager'
+                  throwTo tid (IOManagerError e)
+                  throwIO e
             k iocp
 
 
-data IOCompletionException
-    = NullPointerException
-    | NullOverlappedPointer
-    | IOCompoletionError !Win32.ErrCode
-  deriving Show
-
-
 data IOManagerNotification
     = IOManagerSkip
     -- ^ io manger loop will skip and continue
@@ -167,7 +162,6 @@ data IOManagerNotification
     | IOManagerOperationSuccess !Int           !LPOVERLAPPED
     -- ^ io manager loop received a notification of an erronous IO operation 
 
-instance Exception IOCompletionException
 
 -- | I/O manager which handles completions of I/O operations.  It should run on
 -- a bound thread.  It dereferences the stable pointer which was allocated by
@@ -214,6 +208,13 @@ dequeueCompletionPackets (IOCompletionPort port) = ioManagerLoop
                    -- <https://docs.microsoft.com/en-us/windows/win32/api/ioapiset/nf-ioapiset-getqueuedcompletionstatus#remarks>)
                       pure IOManagerStop
                  | gqcsOverlappedIsNull && errorCode == eRROR_INVALID_HANDLE ->
+                   -- This path is not documented on 'MSDN'; I was only able to
+                   -- reproduce it in some scenarios when closing the iocp
+                   -- handle (which is done by 'withIOManager').  We are not
+                   -- throwing an exception, since this exception would be
+                   -- re-thrown to the application thread when 'withIOManager'
+                   -- exits.
+                   --
                    -- If we don't terminate the dequeueing thread, some of the tests
                    -- will take 10x-100x more time to complete:
                    --
@@ -243,7 +244,7 @@ dequeueCompletionPackets (IOCompletionPort port) = ioManagerLoop
                    -- 'GetLastCompletionStatus' has not dequeued any completion packet
                    -- from the completion port.  Must be the first clause, since if
                    -- this is not true we cannot trust other arguments.
-                      throwIO NullOverlappedPointer
+                      Win32.failWith "dequeueCompletionPackets" errorCode
                  | completionKey /= magicCompletionKey ->
                    -- The completion key does not agree with what we expect, we ignore
                    -- and carry on. The completion key is set when one calls

Win32-network/test/Test/Async/Socket.hs

@@ -50,14 +50,14 @@ tests =
   , testProperty "sendTo and recvFrom"
       (ioProperty . prop_sendTo_recvFrom)
   , testProperty "PingPong test"
-      $ withMaxSuccess 100 prop_PingPong
+      prop_PingPong
   , testProperty "PingPongPipelined test"
-      $ withMaxSuccess 100 prop_PingPongPipelined
+      prop_PingPongPipelined
   , testGroup "vectored io"
     [ testProperty "PingPong test"
-        $ withMaxSuccess 100 prop_PingPongLazy
+        prop_PingPongLazy
     , testProperty "PingPongPipelined test"
-        $ withMaxSuccess 100 prop_PingPongPipelinedLazy
+        prop_PingPongPipelinedLazy
     ]
   ]
 

ouroboros-network/src/Ouroboros/Network/NodeToClient.hs

@@ -439,13 +439,23 @@ networkErrorPolicies = ErrorPolicies
                       MuxBearerClosed         -> Just (SuspendPeer shortDelay shortDelay)
                       MuxIOException{}        -> Just (SuspendPeer shortDelay shortDelay)
                       MuxSDUReadTimeout       -> Just (SuspendPeer shortDelay shortDelay)
+
+        -- Error thrown by 'IOManager', this is fatal on Windows, and it will
+        -- never fire on other platofrms.
+      , ErrorPolicy
+          $ \(_ :: IOManagerError)
+                -> Just Throw
       ]
     , epConErrorPolicies = [
         -- If an 'IOException' is thrown by the 'connect' call we suspend the
         -- peer for 'shortDelay' and we will try to re-connect to it after that
         -- period.
         ErrorPolicy $ \(_ :: IOException) -> Just $
           SuspendPeer shortDelay shortDelay
+
+      , ErrorPolicy
+          $ \(_ :: IOManagerError)
+                -> Just Throw
       ]
     }
   where

ouroboros-network/src/Ouroboros/Network/NodeToNode.hs

@@ -100,6 +100,7 @@ import qualified Network.Socket as Socket
 
 import           Ouroboros.Network.Driver (TraceSendRecv(..))
 import           Ouroboros.Network.Driver.Limits (ProtocolLimitFailure)
+import           Ouroboros.Network.IOManager
 import           Ouroboros.Network.Mux
 import           Ouroboros.Network.Magic
 import           Ouroboros.Network.ErrorPolicy
@@ -735,13 +736,23 @@ remoteNetworkErrorPolicy = ErrorPolicies {
         , ErrorPolicy
             $ \(_ :: BlockFetchProtocolFailure)
                   -> Just theyBuggyOrEvil
+
+          -- Error thrown by 'IOManager', this is fatal on Windows, and it will
+          -- never fire on other platofrms.
+        , ErrorPolicy
+            $ \(_ :: IOManagerError)
+                  -> Just Throw
         ],
 
       -- Exception raised during connect; suspend connecting to that peer for
       -- a 'shortDelay'
       epConErrorPolicies = [
           ErrorPolicy $ \(_ :: IOException) -> Just $
             SuspendConsumer shortDelay
+
+        , ErrorPolicy
+            $ \(_ :: IOManagerError)
+                  -> Just Throw
         ]
     }
   where