include external special remote process number in debug

Not actual pid, because System.Process does not expose that.

diff --git a/Remote/External.hs b/Remote/External.hs
index fb87f44736559be9f8229257a176d76e4e5ae998..a2d5670ec7e3e11118bdcc10c6cfd18d99366495 100644 (file)
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -303,7 +303,7 @@ handleRequest' st external req mp responsehandler
 
 sendMessage :: Sendable m => ExternalState -> External -> m -> Annex ()
 sendMessage st external m = liftIO $ do
-       protocolDebug external True line
+       protocolDebug external st True line
        hPutStrLn h line
        hFlush h
   where
@@ -326,7 +326,7 @@ receiveMessage st external handleresponse handlerequest handleasync =
   where
        go Nothing = protocolError False ""
        go (Just s) = do
-               liftIO $ protocolDebug external False s
+               liftIO $ protocolDebug external st False s
                case parseMessage s :: Maybe Response of
                        Just resp -> maybe (protocolError True s) id (handleresponse resp)
                        Nothing -> case parseMessage s :: Maybe RemoteRequest of
@@ -337,9 +337,10 @@ receiveMessage st external handleresponse handlerequest handleasync =
        protocolError parsed s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
                if parsed then "(command not allowed at this time)" else "(unable to parse command)"
 
-protocolDebug :: External -> Bool -> String -> IO ()
-protocolDebug external sendto line = debugM "external" $ unwords
-       [ externalRemoteProgram (externalType external)
+protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()
+protocolDebug external st sendto line = debugM "external" $ unwords
+       [ externalRemoteProgram (externalType external) ++ 
+               "[" ++ show (externalPid st) ++ "]"
        , if sendto then "<--" else "-->"
        , line
        ]
@@ -388,21 +389,26 @@ startExternal external = do
                        , std_err = CreatePipe
                        }
                p <- propgit g basep
-               (Just hin, Just hout, Just herr, pid) <- 
+               (Just hin, Just hout, Just herr, ph) <- 
                        createProcess p `catchIO` runerr
                fileEncoding hin
                fileEncoding hout
                fileEncoding herr
                stderrelay <- async $ errrelayer herr
-               checkearlytermination =<< getProcessExitCode pid
+               checkearlytermination =<< getProcessExitCode ph
                cv <- newTMVarIO $ externalDefaultConfig external
                pv <- newTMVarIO Unprepared
+               pid <- atomically $ do
+                       n <- succ <$> takeTMVar (externalLastPid external)
+                       putTMVar (externalLastPid external) n
+                       return n
                return $ ExternalState
                        { externalSend = hin
                        , externalReceive = hout
+                       , externalPid = pid
                        , externalShutdown = do
                                cancel stderrelay
-                               void $ waitForProcess pid
+                               void $ waitForProcess ph
                        , externalPrepared = pv
                        , externalConfig = cv
                        }
@@ -423,8 +429,6 @@ startExternal external = do
                        error $ basecmd ++ " is not installed in PATH (" ++ path ++ ")"
                )
 
--- Note: Does not stop any externals that have a withExternalState
--- action currently running.
 stopExternal :: External -> Annex ()
 stopExternal external = liftIO $ do
        l <- atomically $ do

diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 98d391df8048bc688c44b75ce6ce0308e9732eca..33a22aeb17eb4cfcb7a78be8ee6c9482c2fe4f89 100644 (file)
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -48,6 +48,7 @@ data External = External
        , externalState :: TMVar [ExternalState]
        -- ^ TMVar is never left empty; list contains states for external
        -- special remote processes that are not currently in use.
+       , externalLastPid :: TMVar PID
        , externalDefaultConfig :: RemoteConfig
        , externalGitConfig :: RemoteGitConfig
        }
@@ -57,6 +58,7 @@ newExternal externaltype u c gc = liftIO $ External
        <$> pure externaltype
        <*> pure u
        <*> atomically (newTMVar [])
+       <*> atomically (newTMVar 0)
        <*> pure c
        <*> pure gc
 
@@ -66,12 +68,15 @@ data ExternalState = ExternalState
        { externalSend :: Handle
        , externalReceive :: Handle
        , externalShutdown :: IO ()
+       , externalPid :: PID
        , externalPrepared :: TMVar PrepareStatus
        -- ^ Never left empty.
        , externalConfig :: TMVar RemoteConfig
        -- ^ Never left empty.
        }
 
+type PID = Int
+
 data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg
 
 -- Messages that can be sent to the external remote to request it do something.