async exception safety for external special remote processes

Since an external process can be in the middle of some operation when an
async exception is received, it has to be shut down then. Using
cleanupProcess will close its IO handles and send it a SIGTERM.

If a special remote choses to catch SIGTERM, it's fine for it to do some
cleanup then, but until it finishes, git-annex will be blocked waiting
for it. If a special remote blocked SIGTERM, it would cause a hang.
Mentioned in docs.

Also, in passing, fixed a FD leak, it was not closing the error handle
when shutting down the external. In practice that didn't matter before because
it was only run when git-annex was itself shutting down, but now that it
can run on exception, it would have been a problem.

CHANGELOG

@@ -27,6 +27,8 @@ git-annex (8.20200523) UNRELEASED; urgency=medium
   * init: When annex.pidlock is set, skip lock probing.
   * Fix file descriptor leak when importing from a directory special remote
     that is configured with exporttree=yes.
+  * Note that external special remote programs should not block SIGINT or
+    SIGTERM.
 
  -- Joey Hess <id@joeyh.name>  Tue, 26 May 2020 10:20:52 -0400
 

Remote/External.hs

@@ -560,13 +560,24 @@ protocolDebug external st sendto line = debugM "external" $ unwords
 {- While the action is running, the ExternalState provided to it will not
  - be available to any other calls.
  -
- - Starts up a new process if no ExternalStates are available. -}
+ - Starts up a new process if no ExternalStates are available.
+ -
+ - If the action is interrupted by an async exception, the external process
+ - is in an unknown state, and may eg be still performing a transfer. So it
+ - is killed. The action should not normally throw any exception itself,
+ - unless perhaps there's a problem communicating with the external
+ - process.
+ -}
 withExternalState :: External -> (ExternalState -> Annex a) -> Annex a
-withExternalState external = bracket alloc dealloc
+withExternalState external a = do
+	st <- get
+	r <- a st `onException` liftIO (externalShutdown st True)
+	put st -- only when no exception is thrown
+	return r
   where
 	v = externalState external
 
-	alloc = do
+	get = do
 		ms <- liftIO $ atomically $ do
 			l <- readTVar v
 			case l of
@@ -576,7 +587,7 @@ withExternalState external = bracket alloc dealloc
 					return (Just st)
 		maybe (startExternal external) return ms
 	
-	dealloc st = liftIO $ atomically $ modifyTVar' v (st:)
+	put st = liftIO $ atomically $ modifyTVar' v (st:)
 
 {- Starts an external remote process running, and checks VERSION and
  - exchanges EXTENSIONS. -}
@@ -611,7 +622,7 @@ startExternal external = do
 			, std_err = CreatePipe
 			}
 		p <- propgit g basep
-		(Just hin, Just hout, Just herr, ph) <- 
+		pall@(Just hin, Just hout, Just herr, ph) <- 
 			createProcess p `catchNonAsync` runerr cmdpath
 		stderrelay <- async $ errrelayer herr
 		cv <- newTVarIO $ externalDefaultConfig external
@@ -621,13 +632,20 @@ startExternal external = do
 			n <- succ <$> readTVar (externalLastPid external)
 			writeTVar (externalLastPid external) n
 			return n
+		let shutdown forcestop = do
+			cancel stderrelay
+			if forcestop
+				then cleanupProcess pall
+				else flip onException (cleanupProcess pall) $ do
+					hClose herr
+					hClose hin
+					hClose hout
+					void $ waitForProcess ph
 		return $ ExternalState
 			{ externalSend = hin
 			, externalReceive = hout
 			, externalPid = pid
-			, externalShutdown = do
-				cancel stderrelay
-				void $ waitForProcess ph
+			, externalShutdown = shutdown
 			, externalPrepared = pv
 			, externalConfig = cv
 			, externalConfigChanges = ccv
@@ -657,12 +675,7 @@ startExternal external = do
 stopExternal :: External -> Annex ()
 stopExternal external = liftIO $ do
 	l <- atomically $ swapTVar (externalState external) []
-	mapM_ stop l
-  where
-	stop st = do
-		hClose $ externalSend st
-		hClose $ externalReceive st
-		externalShutdown st
+	mapM_ (flip externalShutdown False) l
 
 externalRemoteProgram :: ExternalType -> String
 externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype

Remote/External/Types.hs

@@ -77,7 +77,7 @@ type ExternalType = String
 data ExternalState = ExternalState
 	{ externalSend :: Handle
 	, externalReceive :: Handle
-	, externalShutdown :: IO ()
+	, externalShutdown :: Bool -> IO ()
 	, externalPid :: PID
 	, externalPrepared :: TVar PrepareStatus
 	, externalConfig :: TVar ParsedRemoteConfig

doc/design/external_special_remote_protocol.mdwn

@@ -403,6 +403,13 @@ remote.
   git-annex will not talk to it any further. If the program receives
   an ERROR from git-annex, it can exit with its own ERROR.
 
+## signals
+
+The external special remote program should not block SIGINT, or SIGTERM.
+Doing so may cause git-annex to hang waiting on it to exit.
+Of course it's ok to catch those signals and do some necessary cleanup
+before exiting.
+
 ## long running network connections
 
 Since an external special remote is started only when git-annex needs to