Fix async exception handling (#86)

Previously, grpc-haskell used a lot of code in the form of

```
do x <- acquireResource
   f x `finally` releaseResource x
```

This is not safe since you can get killed after acquiring the resource
but before installing the exception handler via `finally`. We have
seen various gRPC assertion errors and crashes on shutdown when this
got triggered.

core/src/Network/GRPC/LowLevel/Client.hs

@@ -11,7 +11,7 @@
 -- `Network.GRPC.LowLevel.Client.Unregistered`.
 module Network.GRPC.LowLevel.Client where
 
-import           Control.Exception                     (bracket, finally)
+import           Control.Exception                     (bracket)
 import           Control.Concurrent.MVar
 import           Control.Monad
 import           Control.Monad.IO.Class
@@ -222,9 +222,12 @@ withClientCallParent :: Client
                      -> (ClientCall -> IO (Either GRPCIOError a))
                      -> IO (Either GRPCIOError a)
 withClientCallParent cl rm tm parent f =
-  clientCreateCallParent cl rm tm parent >>= \case
+  bracket (clientCreateCallParent cl rm tm parent) cleanup $ \case
     Left e  -> return (Left e)
-    Right c -> f c `finally` do
+    Right c -> f c
+  where
+    cleanup (Left _) = pure ()
+    cleanup (Right c) = do
       debugClientCall c
       grpcDebug "withClientCall(R): destroying."
       destroyClientCall c

core/src/Network/GRPC/LowLevel/Client/Unregistered.hs

@@ -1,10 +1,11 @@
+{-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns    #-}
 
 module Network.GRPC.LowLevel.Client.Unregistered where
 
 import           Control.Arrow
-import           Control.Exception                                  (finally)
+import           Control.Exception                                  (bracket)
 import           Control.Monad                                      (join)
 import           Data.ByteString                                    (ByteString)
 import           Foreign.Ptr                                        (nullPtr)
@@ -40,13 +41,15 @@ withClientCall :: Client
                -> TimeoutSeconds
                -> (ClientCall -> IO (Either GRPCIOError a))
                -> IO (Either GRPCIOError a)
-withClientCall client method timeout f = do
+withClientCall client method timeout f =
-  createResult <- clientCreateCall client method timeout
+  bracket (clientCreateCall client method timeout) cleanup $ \case
-  case createResult of
     Left x -> return $ Left x
-    Right call -> f call `finally` logDestroy call
+    Right call -> f call
-                    where logDestroy c = grpcDebug "withClientCall(U): destroying."
+  where
-                                         >> destroyClientCall c
+    cleanup (Left _) = pure ()
+    cleanup (Right call) = do
+      grpcDebug "withClientCall(U): destroying."
+      destroyClientCall call
 
 -- | Makes a normal (non-streaming) request without needing to register a method
 -- first. Probably only useful for testing.

core/src/Network/GRPC/LowLevel/Server.hs

@@ -26,7 +26,7 @@ import           Control.Concurrent.STM.TVar           (TVar
                                                         , writeTVar
                                                         , readTVarIO
                                                         , newTVarIO)
-import           Control.Exception                     (bracket, finally)
+import           Control.Exception                     (bracket)
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Except
@@ -343,11 +343,14 @@ withServerCall :: Server
                -> (ServerCall (MethodPayload mt) -> IO (Either GRPCIOError a))
                -> IO (Either GRPCIOError a)
 withServerCall s rm f =
-    serverCreateCall s rm >>= \case
+  bracket (serverCreateCall s rm) cleanup $ \case
     Left e  -> return (Left e)
     Right c -> do
       debugServerCall c
-        f c `finally` do
+      f c
+  where
+    cleanup (Left _) = pure ()
+    cleanup (Right c) = do
       grpcDebug "withServerCall(R): destroying."
       destroyServerCall c
 

core/src/Network/GRPC/LowLevel/Server/Unregistered.hs

@@ -3,7 +3,7 @@
 
 module Network.GRPC.LowLevel.Server.Unregistered where
 
-import           Control.Exception                                  (finally)
+import           Control.Exception                                  (bracket, finally, mask)
 import           Control.Monad
 import           Control.Monad.Trans.Except
 import           Data.ByteString                                    (ByteString)
@@ -30,9 +30,12 @@ withServerCall :: Server
                -> (ServerCall -> IO (Either GRPCIOError a))
                -> IO (Either GRPCIOError a)
 withServerCall s f =
-  serverCreateCall s >>= \case
+  bracket (serverCreateCall s) cleanup $ \case
     Left e -> return (Left e)
-    Right c -> f c `finally` do
+    Right c -> f c
+  where
+    cleanup (Left _) = pure ()
+    cleanup (Right c) = do
       grpcDebug "withServerCall: destroying."
       destroyServerCall c
 
@@ -44,13 +47,13 @@ withServerCall s f =
 withServerCallAsync :: Server
                     -> (ServerCall -> IO ())
                     -> IO ()
-withServerCallAsync s f =
+withServerCallAsync s f = mask $ \unmask ->
   serverCreateCall s >>= \case
     Left e -> do grpcDebug $ "withServerCallAsync: call error: " ++ show e
                  return ()
     Right c -> do wasForkSuccess <- forkServer s handler
                   unless wasForkSuccess destroy
-                where handler = f c `finally` destroy
+                where handler = unmask (f c) `finally` destroy
                       -- TODO: We sometimes never finish cleanup if the server
                       -- is shutting down and calls killThread. This causes gRPC
                       -- core to complain about leaks.  I think the cause of