include external special remote process number in debug
Not actual pid, because System.Process does not expose that.
This commit is contained in:
parent
5bf4623a1d
commit
37c8c6df99
2 changed files with 19 additions and 10 deletions
|
@ -303,7 +303,7 @@ handleRequest' st external req mp responsehandler
|
||||||
|
|
||||||
sendMessage :: Sendable m => ExternalState -> External -> m -> Annex ()
|
sendMessage :: Sendable m => ExternalState -> External -> m -> Annex ()
|
||||||
sendMessage st external m = liftIO $ do
|
sendMessage st external m = liftIO $ do
|
||||||
protocolDebug external True line
|
protocolDebug external st True line
|
||||||
hPutStrLn h line
|
hPutStrLn h line
|
||||||
hFlush h
|
hFlush h
|
||||||
where
|
where
|
||||||
|
@ -326,7 +326,7 @@ receiveMessage st external handleresponse handlerequest handleasync =
|
||||||
where
|
where
|
||||||
go Nothing = protocolError False ""
|
go Nothing = protocolError False ""
|
||||||
go (Just s) = do
|
go (Just s) = do
|
||||||
liftIO $ protocolDebug external False s
|
liftIO $ protocolDebug external st False s
|
||||||
case parseMessage s :: Maybe Response of
|
case parseMessage s :: Maybe Response of
|
||||||
Just resp -> maybe (protocolError True s) id (handleresponse resp)
|
Just resp -> maybe (protocolError True s) id (handleresponse resp)
|
||||||
Nothing -> case parseMessage s :: Maybe RemoteRequest of
|
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 ++ "\" " ++
|
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)"
|
if parsed then "(command not allowed at this time)" else "(unable to parse command)"
|
||||||
|
|
||||||
protocolDebug :: External -> Bool -> String -> IO ()
|
protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()
|
||||||
protocolDebug external sendto line = debugM "external" $ unwords
|
protocolDebug external st sendto line = debugM "external" $ unwords
|
||||||
[ externalRemoteProgram (externalType external)
|
[ externalRemoteProgram (externalType external) ++
|
||||||
|
"[" ++ show (externalPid st) ++ "]"
|
||||||
, if sendto then "<--" else "-->"
|
, if sendto then "<--" else "-->"
|
||||||
, line
|
, line
|
||||||
]
|
]
|
||||||
|
@ -388,21 +389,26 @@ startExternal external = do
|
||||||
, std_err = CreatePipe
|
, std_err = CreatePipe
|
||||||
}
|
}
|
||||||
p <- propgit g basep
|
p <- propgit g basep
|
||||||
(Just hin, Just hout, Just herr, pid) <-
|
(Just hin, Just hout, Just herr, ph) <-
|
||||||
createProcess p `catchIO` runerr
|
createProcess p `catchIO` runerr
|
||||||
fileEncoding hin
|
fileEncoding hin
|
||||||
fileEncoding hout
|
fileEncoding hout
|
||||||
fileEncoding herr
|
fileEncoding herr
|
||||||
stderrelay <- async $ errrelayer herr
|
stderrelay <- async $ errrelayer herr
|
||||||
checkearlytermination =<< getProcessExitCode pid
|
checkearlytermination =<< getProcessExitCode ph
|
||||||
cv <- newTMVarIO $ externalDefaultConfig external
|
cv <- newTMVarIO $ externalDefaultConfig external
|
||||||
pv <- newTMVarIO Unprepared
|
pv <- newTMVarIO Unprepared
|
||||||
|
pid <- atomically $ do
|
||||||
|
n <- succ <$> takeTMVar (externalLastPid external)
|
||||||
|
putTMVar (externalLastPid external) n
|
||||||
|
return n
|
||||||
return $ ExternalState
|
return $ ExternalState
|
||||||
{ externalSend = hin
|
{ externalSend = hin
|
||||||
, externalReceive = hout
|
, externalReceive = hout
|
||||||
|
, externalPid = pid
|
||||||
, externalShutdown = do
|
, externalShutdown = do
|
||||||
cancel stderrelay
|
cancel stderrelay
|
||||||
void $ waitForProcess pid
|
void $ waitForProcess ph
|
||||||
, externalPrepared = pv
|
, externalPrepared = pv
|
||||||
, externalConfig = cv
|
, externalConfig = cv
|
||||||
}
|
}
|
||||||
|
@ -423,8 +429,6 @@ startExternal external = do
|
||||||
error $ basecmd ++ " is not installed in PATH (" ++ path ++ ")"
|
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 -> Annex ()
|
||||||
stopExternal external = liftIO $ do
|
stopExternal external = liftIO $ do
|
||||||
l <- atomically $ do
|
l <- atomically $ do
|
||||||
|
|
5
Remote/External/Types.hs
vendored
5
Remote/External/Types.hs
vendored
|
@ -48,6 +48,7 @@ data External = External
|
||||||
, externalState :: TMVar [ExternalState]
|
, externalState :: TMVar [ExternalState]
|
||||||
-- ^ TMVar is never left empty; list contains states for external
|
-- ^ TMVar is never left empty; list contains states for external
|
||||||
-- special remote processes that are not currently in use.
|
-- special remote processes that are not currently in use.
|
||||||
|
, externalLastPid :: TMVar PID
|
||||||
, externalDefaultConfig :: RemoteConfig
|
, externalDefaultConfig :: RemoteConfig
|
||||||
, externalGitConfig :: RemoteGitConfig
|
, externalGitConfig :: RemoteGitConfig
|
||||||
}
|
}
|
||||||
|
@ -57,6 +58,7 @@ newExternal externaltype u c gc = liftIO $ External
|
||||||
<$> pure externaltype
|
<$> pure externaltype
|
||||||
<*> pure u
|
<*> pure u
|
||||||
<*> atomically (newTMVar [])
|
<*> atomically (newTMVar [])
|
||||||
|
<*> atomically (newTMVar 0)
|
||||||
<*> pure c
|
<*> pure c
|
||||||
<*> pure gc
|
<*> pure gc
|
||||||
|
|
||||||
|
@ -66,12 +68,15 @@ data ExternalState = ExternalState
|
||||||
{ externalSend :: Handle
|
{ externalSend :: Handle
|
||||||
, externalReceive :: Handle
|
, externalReceive :: Handle
|
||||||
, externalShutdown :: IO ()
|
, externalShutdown :: IO ()
|
||||||
|
, externalPid :: PID
|
||||||
, externalPrepared :: TMVar PrepareStatus
|
, externalPrepared :: TMVar PrepareStatus
|
||||||
-- ^ Never left empty.
|
-- ^ Never left empty.
|
||||||
, externalConfig :: TMVar RemoteConfig
|
, externalConfig :: TMVar RemoteConfig
|
||||||
-- ^ Never left empty.
|
-- ^ Never left empty.
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type PID = Int
|
||||||
|
|
||||||
data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg
|
data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg
|
||||||
|
|
||||||
-- Messages that can be sent to the external remote to request it do something.
|
-- Messages that can be sent to the external remote to request it do something.
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue