diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-09-30 14:42:48 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-09-30 14:47:36 -0400 |
commit | d1d8395a3745fd81dc0a0ee8a590a22f85cc5bd4 (patch) | |
tree | fd75c92ca301d68eeda0235063a9415530169a53 | |
parent | f42a64198f18708623fc7a6f7e53cfb3b9e5642b (diff) |
include external special remote process number in debug
Not actual pid, because System.Process does not expose that.
-rw-r--r-- | Remote/External.hs | 24 | ||||
-rw-r--r-- | Remote/External/Types.hs | 5 |
2 files changed, 19 insertions, 10 deletions
diff --git a/Remote/External.hs b/Remote/External.hs index fb87f4473..a2d5670ec 100644 --- 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 98d391df8..33a22aeb1 100644 --- 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. |