Remove XIO

It served its purpose, allowing us to be more precise about which exceptions we want to handle here. Although it has not yet unlived its usefulness, it was also poorly motivated, and there were concerns about unsoundness (what happens if you try to `liftIO takeMVar`?). We could fix it, and perhaps one day we should, but for now we just remove it altogether; it's not a problem we must solve for this project.
well-typed · Jul 23, 2024 · 8f83701 · 8f83701
1 parent 863b65e
commit 8f83701
Show file tree

Hide file tree

Showing 10 changed files with 134 additions and 366 deletions.
diff --git a/grapesy.cabal b/grapesy.cabal
@@ -112,7 +112,6 @@ library
       Network.GRPC.Common.StreamElem
       Network.GRPC.Common.StreamType
       Network.GRPC.Common.HTTP2Settings
-      Network.GRPC.Internal.XIO
       Network.GRPC.Server
       Network.GRPC.Server.Binary
       Network.GRPC.Server.Protobuf
@@ -177,14 +176,11 @@ library
       Paths_grapesy
 
       Proto.OrcaLoadReport
-
-      Control.Monad.XIO
   autogen-modules:
       Paths_grapesy
   hs-source-dirs:
       src
       util
-      xio
       proto
   build-depends:
     , aeson                >= 1.5     && < 2.3

diff --git a/interop/Interop/Server.hs b/interop/Interop/Server.hs
@@ -3,11 +3,10 @@ module Interop.Server (
     , runInteropServer
     ) where
 
-import Control.Exception (SomeException)
+import Control.Exception
 import Control.Monad.Catch (generalBracket, ExitCase(..))
 
 import Network.GRPC.Common
-import Network.GRPC.Internal.XIO qualified as XIO
 import Network.GRPC.Server
 import Network.GRPC.Server.Protobuf
 import Network.GRPC.Server.Run
@@ -101,10 +100,11 @@ withInteropServer cmdline k = do
         }
 
     -- Don't show handler exceptions on stderr
-    swallowExceptions ::
-         RequestHandler SomeException ()
-      -> RequestHandler XIO.NeverThrows   ()
-    swallowExceptions h req resp = h req resp `XIO.catchError` \_ -> return ()
+    swallowExceptions :: RequestHandler () -> RequestHandler ()
+    swallowExceptions h unmask req resp = h unmask req resp `catch` handler
+      where
+        handler :: SomeException -> IO ()
+        handler _ = return ()
 
 runInteropServer :: Cmdline -> IO ()
 runInteropServer cmdline = withInteropServer cmdline $ \server ->

diff --git a/src/Network/GRPC/Server/Call.hs b/src/Network/GRPC/Server/Call.hs
@@ -45,8 +45,6 @@ import Control.Concurrent.STM
 import Control.Exception (throwIO)
 import Control.Monad
 import Control.Monad.Catch
-import Control.Monad.XIO (XIO')
-import Control.Monad.XIO qualified as XIO
 import Data.Bitraversable
 import Data.Default
 import Data.List.NonEmpty (NonEmpty)
@@ -129,17 +127,18 @@ kickoffCallStack (KickoffTrailersOnly cs _) = cs
 -- | Setup call
 --
 -- No response is sent to the caller.
+--
+-- May throw 'CallSetupFailure'.
 setupCall :: forall rpc.
      SupportsServerRpc rpc
   => Server.ConnectionToClient
   -> ServerContext
-  -> XIO' CallSetupFailure (Call rpc)
+  -> IO (Call rpc)
 setupCall conn callContext@ServerContext{serverParams} = do
-    callResponseMetadata <- XIO.unsafeTrustMe $ newTVarIO Nothing
-    callResponseKickoff  <- XIO.unsafeTrustMe $ newEmptyTMVarIO
+    callResponseMetadata <- newTVarIO Nothing
+    callResponseKickoff  <- newEmptyTMVarIO
 
-    inboundHeaders <-
-      XIO.unsafeTrustMe $ determineInbound callSession req
+    inboundHeaders <- determineInbound callSession req
     let callRequestHeaders = inbHeaders inboundHeaders
 
     -- Technically compression is only relevant in the 'KickoffRegular' case
@@ -151,7 +150,7 @@ setupCall conn callContext@ServerContext{serverParams} = do
                  requestAcceptCompression callRequestHeaders
 
     callChannel :: Session.Channel (ServerSession rpc) <-
-      XIO.neverThrows $ Session.setupResponseChannel
+      Session.setupResponseChannel
         callSession
         conn
         (Session.FlowStartRegular inboundHeaders)

diff --git a/src/Network/GRPC/Server/Context.hs b/src/Network/GRPC/Server/Context.hs
@@ -10,8 +10,6 @@ module Network.GRPC.Server.Context (
   ) where
 
 import Control.Exception
-import Control.Monad.XIO (NeverThrows)
-import Control.Monad.XIO qualified as XIO
 import Data.Default
 import System.IO
 
@@ -55,9 +53,7 @@ data ServerParams = ServerParams {
       -- full control over how requests are handled.
       --
       -- The default merely logs any exceptions to 'stderr'.
-    , serverTopLevel ::
-           RequestHandler SomeException ()
-        -> RequestHandler NeverThrows   ()
+    , serverTopLevel :: RequestHandler () -> RequestHandler ()
 
       -- | Render handler-side exceptions for the client
       --
@@ -113,11 +109,12 @@ instance Default ServerParams where
       , serverHTTP2Settings           = def
       }
 
-defaultServerTopLevel ::
-     RequestHandler SomeException ()
-  -> RequestHandler NeverThrows   ()
-defaultServerTopLevel h req resp =
-    h req resp `XIO.catchError` (XIO.swallowIO . hPrint stderr)
+defaultServerTopLevel :: RequestHandler () -> RequestHandler ()
+defaultServerTopLevel h unmask req resp =
+    h unmask req resp `catch` handler
+  where
+    handler :: SomeException -> IO ()
+    handler = hPrint stderr
 
 -- | Default implementation for 'serverExceptionToClient'
 --

diff --git a/src/Network/GRPC/Server/Handler.hs b/src/Network/GRPC/Server/Handler.hs
@@ -21,8 +21,6 @@ import Control.Concurrent.Async
 import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
-import Control.Monad.XIO (XIO, XIO', NeverThrows)
-import Control.Monad.XIO qualified as XIO
 import Data.Default
 import Data.Kind
 import Data.Proxy
@@ -158,40 +156,37 @@ hoistSomeRpcHandler f (SomeRpcHandler p h) =
 -- of what happened (see 'forwardException') before re-throwing the exception.
 runHandler :: forall rpc.
      HasCallStack
-  => Call rpc
+  => (forall x. IO x -> IO x)
+  -> Call rpc
   -> RpcHandler IO rpc
-  -> XIO ()
-runHandler call (RpcHandler k) = do
+  -> IO ()
+runHandler unmask call (RpcHandler k) = do
     -- http2 will kill the handler when the client disappears, but we want the
     -- handler to be able to terminate cleanly. We therefore run the handler in
     -- a separate thread, and wait for that thread to terminate.
-    handlerThread <- liftIO $ asyncLabelled "grapesy:handler" $
-                       XIO.runThrow handler
-    waitForHandler call handlerThread
+    handlerThread <- asyncLabelled "grapesy:handler" handler
+    waitForHandler unmask call handlerThread
   where
     -- The handler itself will run in a separate thread
-    handler :: XIO ()
+    handler :: IO ()
     handler = do
-        result <- liftIO $ try $ k call
+        result <- try $ k call
         handlerTeardown result
 
     -- Deal with any exceptions thrown in the handler
-    handlerTeardown :: Either SomeException () -> XIO ()
+    handlerTeardown :: Either SomeException () -> IO ()
     handlerTeardown (Right ()) = do
         -- Handler terminated successfully, but may not have sent final message.
         -- /If/ the final message was sent, 'forwardException' does nothing.
-        forwarded <- XIO.neverThrows $ do
-          forwarded <- forwardException call $ toException HandlerTerminated
-          ignoreUncleanClose call $ ExitCaseSuccess ()
-          return forwarded
+        forwarded <- forwardException call $ toException HandlerTerminated
+        ignoreUncleanClose call $ ExitCaseSuccess ()
         when forwarded $
           -- The handler terminated before it sent the final message.
           throwM HandlerTerminated
     handlerTeardown (Left err) = do
         -- The handler threw an exception. Attempt to tell the client.
-        XIO.neverThrows $ do
-          void $ forwardException call err
-          ignoreUncleanClose call $ ExitCaseException err
+        void $ forwardException call err
+        ignoreUncleanClose call $ ExitCaseException err
         throwM err
 
 -- | Close the connection to the client, ignoring errors
@@ -211,9 +206,9 @@ runHandler call (RpcHandler k) = do
 --
 --    So there not really anything we can do here (except perhaps show
 --    the exception in 'serverTopLevel').
-ignoreUncleanClose :: Call rpc -> ExitCase a -> XIO' NeverThrows ()
+ignoreUncleanClose :: Call rpc -> ExitCase a -> IO ()
 ignoreUncleanClose Call{callChannel} reason =
-    XIO.swallowIO $ void $ Session.close callChannel reason
+    void $ Session.close callChannel reason
 
 -- | Wait for the handler to terminate
 --
@@ -237,13 +232,16 @@ ignoreUncleanClose Call{callChannel} reason =
 -- This is in line with the overall design philosophy of communication in this
 -- library: exceptions will only be raised synchronously when communication is
 -- attempted, not asynchronously when we notice a problem.
-waitForHandler :: HasCallStack => Call rpc -> Async () -> XIO ()
-waitForHandler call handlerThread = loop
+waitForHandler ::
+     HasCallStack
+  => (forall x. IO x -> IO x)
+  -> Call rpc -> Async () -> IO ()
+waitForHandler unmask call handlerThread = loop
   where
-    loop :: XIO ()
-    loop = liftIO (wait handlerThread) `catch` handleException
+    loop :: IO ()
+    loop = unmask (wait handlerThread) `catch` handleException
 
-    handleException :: SomeException -> XIO ()
+    handleException :: SomeException -> IO ()
     handleException err
       | Just (HTTP2.KilledByHttp2ThreadManager mErr) <- fromException err = do
           let exitReason :: ExitCase ()
@@ -253,7 +251,7 @@ waitForHandler call handlerThread = loop
                   Just exitWithException ->
                     ExitCaseException . toException $
                       ClientDisconnected exitWithException callStack
-          XIO.neverThrows $ ignoreUncleanClose call exitReason
+          ignoreUncleanClose call exitReason
           loop
 
       | otherwise = do
@@ -265,7 +263,7 @@ waitForHandler call handlerThread = loop
           --    exception to the handler (and wait for it to terminate).
           -- 2. The exception was thrown by the handler itself. In this
           --    case @cancelWith@ is a no-op.
-          liftIO $ cancelWith handlerThread err
+          cancelWith handlerThread err
           throwM err
 
 -- | Process exception thrown by a handler
@@ -281,7 +279,10 @@ waitForHandler call handlerThread = loop
 --
 -- We therefore catch and suppress all exceptions here. Returns @True@ if the
 -- forwarding was successful, @False@ if it raised an exception.
-forwardException :: Call rpc -> SomeException -> XIO' NeverThrows Bool
-forwardException call@Call{callContext} err = XIO.swallowIO' $ do
+forwardException :: Call rpc -> SomeException -> IO Bool
+forwardException call@Call{callContext} err = do
     trailers <- serverExceptionToClientError (serverParams callContext) err
-    sendProperTrailers call trailers
+    (True <$ sendProperTrailers call trailers) `catch` handler
+ where
+   handler :: SomeException -> IO Bool
+   handler _ = return False