From b9cfd15e906fc0fab6204ddf23aa8bf39c4c158e Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 8 Dec 2020 11:43:06 -0400
Subject: [PATCH] add killTransferrer

There is redundant code in the assistant that does the same thing,
but that code uses a PID, not a ProcessHandle, and gets the PID from,
apparently, the TransferInfo transferPid (although I can't seem to find
where that gets set on non-windows).
---
 Annex/TransferrerPool.hs | 25 +++++++++++++++++--------
 1 file changed, 17 insertions(+), 8 deletions(-)

diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs
index f5ab42e0db..cdfe45dad1 100644
--- a/Annex/TransferrerPool.hs
+++ b/Annex/TransferrerPool.hs
@@ -129,14 +129,6 @@ mkTransferrer program batchmaker = do
 		, transferrerHandle = pid
 		}
 
-{- Closing the fds will shut down the transferrer, but only when it's
- - in between transfers. -}
-shutdownTransferrer :: Transferrer -> IO ()
-shutdownTransferrer t = do
-	hClose $ transferrerRead t
-	hClose $ transferrerWrite t
-	void $ waitForProcess $ transferrerHandle t
-
 -- | Send a request to perform a transfer.
 sendRequest :: TransferRequestLevel -> Transfer -> Maybe Remote -> AssociatedFile -> Handle -> IO ()
 sendRequest level t mremote afile h = do
@@ -167,3 +159,20 @@ readResponse h = do
 
 transferKeysProtocolError :: String -> a
 transferKeysProtocolError l = error $ "transferkeys protocol error: " ++ show l
+
+{- Closing the fds will shut down the transferrer, but only when it's
+ - in between transfers. -}
+shutdownTransferrer :: Transferrer -> IO ()
+shutdownTransferrer t = do
+	hClose $ transferrerRead t
+	hClose $ transferrerWrite t
+	void $ waitForProcess $ transferrerHandle t
+
+{- Kill the transferrer, and all its child processes. -}
+killTransferrer :: Transferrer -> IO ()
+killTransferrer t = do
+	hClose $ transferrerRead t
+	hClose $ transferrerWrite t
+	interruptProcessGroupOf $ transferrerHandle t
+	threadDelay 50000 -- 0.05 second grace period
+	terminateProcess $ transferrerHandle t