Fix up parent calls (#36)

* remove parentPtr from server calls

* remove parentPtr from ServerCall, add new withClientCallParent

src/Network/GRPC/LowLevel.hs

@@ -51,6 +51,7 @@ GRPC
 , clientRegisterMethod
 , clientRequest
 , withClientCall
+, withClientCallParent
 , clientCallCancel
 
 -- * Ops

src/Network/GRPC/LowLevel/Call.hs

@@ -63,7 +63,6 @@ data ServerCall = ServerCall
   { unServerCall        :: C.Call,
     requestMetadataRecv :: MetadataMap,
     optionalPayload     :: Maybe ByteString,
-    parentPtr           :: Maybe (Ptr C.Call),
     callDeadline        :: TimeSpec
   }
 
@@ -87,15 +86,11 @@ debugClientCall = const $ return ()
 
 debugServerCall :: ServerCall -> IO ()
 #ifdef DEBUG
-debugServerCall call@(ServerCall (C.Call ptr) _ _ _ _) = do
+debugServerCall call@(ServerCall (C.Call ptr) _ _ _) = do
   grpcDebug $ "debugServerCall(R): server call: " ++ (show ptr)
   grpcDebug $ "debugServerCall(R): metadata ptr: "
               ++ show (requestMetadataRecv call)
   grpcDebug $ "debugServerCall(R): payload ptr: " ++ show (optionalPayload call)
-  forM_ (parentPtr call) $ \parentPtr' -> do
-    grpcDebug $ "debugServerCall(R): parent ptr: " ++ show parentPtr'
-    (C.Call parent) <- peek parentPtr'
-    grpcDebug $ "debugServerCall(R): parent: " ++ show parent
   grpcDebug $ "debugServerCall(R): deadline ptr: " ++ show (callDeadline call)
 #else
 {-# INLINE debugServerCall #-}
@@ -113,5 +108,3 @@ destroyServerCall call@ServerCall{..} = do
   debugServerCall call
   grpcDebug $ "Destroying server-side call object: " ++ show unServerCall
   C.grpcCallDestroy unServerCall
-  grpcDebug $ "freeing parentPtr: " ++ show parentPtr
-  forM_ parentPtr free

src/Network/GRPC/LowLevel/Client.hs

@@ -89,22 +89,44 @@ clientCreateCall :: Client
                  -> RegisteredMethod
                  -> TimeoutSeconds
                  -> IO (Either GRPCIOError ClientCall)
-clientCreateCall Client{..} RegisteredMethod{..} timeout = do
+clientCreateCall c rm ts = clientCreateCallParent c rm ts Nothing
-  let parentCall = C.Call nullPtr --Unsure what this does. null is safe, though.
+
+-- | For servers that act as clients to other gRPC servers, this version creates
+-- a client call with an optional parent server call. This allows for cascading
+-- call cancellation from the `ServerCall` to the `ClientCall`.
+clientCreateCallParent :: Client
+                           -> RegisteredMethod
+                           -> TimeoutSeconds
+                           -> (Maybe ServerCall)
+                           -- ^ Optional parent call for cascading cancellation.
+                           -> IO (Either GRPCIOError ClientCall)
+clientCreateCallParent Client{..} RegisteredMethod{..} timeout parent = do
   C.withDeadlineSeconds timeout $ \deadline -> do
-    channelCreateCall clientChannel parentCall C.propagateDefaults
+    channelCreateCall clientChannel parent C.propagateDefaults
       clientCQ methodHandle deadline
 
--- TODO: the error-handling refactor made this quite ugly. It could be fixed
--- by switching to ExceptT IO.
 -- | Handles safe creation and cleanup of a client call
 withClientCall :: Client
                -> RegisteredMethod
                -> TimeoutSeconds
                -> (ClientCall -> IO (Either GRPCIOError a))
                -> IO (Either GRPCIOError a)
-withClientCall client regmethod timeout f = do
+withClientCall client regmethod timeout f =
-  createResult <- clientCreateCall client regmethod timeout
+  withClientCallParent client regmethod timeout Nothing f
+
+-- | Handles safe creation and cleanup of a client call, with an optional parent
+-- call parameter. This allows for cancellation to cascade from the parent
+-- `ServerCall` to the created `ClientCall`. Obviously, this is only useful if
+-- the given gRPC client is also a server.
+withClientCallParent :: Client
+                        -> RegisteredMethod
+                        -> TimeoutSeconds
+                        -> (Maybe ServerCall)
+                        -- ^ Optional parent call for cascading cancellation.
+                        -> (ClientCall -> IO (Either GRPCIOError a))
+                        -> IO (Either GRPCIOError a)
+withClientCallParent client regmethod timeout parent f = do
+  createResult <- clientCreateCallParent client regmethod timeout parent
   case createResult of
     Left x -> return $ Left x
     Right call -> f call `finally` logDestroy call

src/Network/GRPC/LowLevel/CompletionQueue.hs

@@ -111,7 +111,7 @@ shutdownCompletionQueue (CompletionQueue{..}) = do
             C.OpComplete -> drainLoop
 
 channelCreateCall :: C.Channel
-                  -> C.Call
+                  -> (Maybe ServerCall)
                   -> C.PropagationMask
                   -> CompletionQueue
                   -> C.CallHandle
@@ -120,11 +120,13 @@ channelCreateCall :: C.Channel
 channelCreateCall
   chan parent mask cq@CompletionQueue{..} handle deadline =
   withPermission Push cq $ do
+    let parentPtr = maybe (C.Call nullPtr) unServerCall parent
     grpcDebug $ "channelCreateCall: call with "
-                ++ concat (intersperse " " [show chan, show parent, show mask,
+                ++ concat (intersperse " " [show chan, show parentPtr,
+                                            show mask,
                                             show unsafeCQ, show handle,
                                             show deadline])
-    call <- C.grpcChannelCreateRegisteredCall chan parent mask unsafeCQ
+    call <- C.grpcChannelCreateRegisteredCall chan parentPtr mask unsafeCQ
                                               handle deadline C.reserved
     return $ Right $ ClientCall call
 
@@ -167,7 +169,6 @@ serverRequestCall
                            let assembledCall = ServerCall rawCall
                                                           meta
                                                           payload
-                                                          Nothing
                                                           deadline
                            grpcDebug "serverRequestCall(R): About to return"
                            return $ Right assembledCall