mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

include external special remote process number in debug

Browse source 
Not actual pid, because System.Process does not expose that.
This commit is contained in:
Joey Hess 2016-09-30 14:42:48 -04:00
parent 5bf4623a1d
commit 37c8c6df99
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
2 changed files with 19 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

24
Remote/External.hs
View file

@ -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