better error messages when external special remote exits unexpectedly or is not in PATH

This commit is contained in:
Joey Hess 2013-12-27 17:14:44 -04:00
parent 8cfaadf55c
commit aa97a33dde

View file

@ -256,8 +256,12 @@ receiveMessage
-> (RemoteRequest -> Maybe (Annex a)) -> (RemoteRequest -> Maybe (Annex a))
-> (AsyncMessage -> Maybe (Annex a)) -> (AsyncMessage -> Maybe (Annex a))
-> Annex a -> Annex a
receiveMessage lck external handleresponse handlerequest handleasync = do receiveMessage lck external handleresponse handlerequest handleasync =
s <- fromExternal lck external externalReceive $ liftIO . hGetLine go =<< fromExternal lck external externalReceive
(liftIO . catchMaybeIO . hGetLine)
where
go Nothing = protocolError False ""
go (Just s) = do
liftIO $ protocolDebug external False s liftIO $ protocolDebug external 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)
@ -266,7 +270,6 @@ receiveMessage lck external handleresponse handlerequest handleasync = do
Nothing -> case parseMessage s :: Maybe AsyncMessage of Nothing -> case parseMessage s :: Maybe AsyncMessage of
Just msg -> maybe (protocolError True s) id (handleasync msg) Just msg -> maybe (protocolError True s) id (handleasync msg)
Nothing -> protocolError False s Nothing -> protocolError False s
where
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)"
@ -307,20 +310,28 @@ fromExternal lck external extractor a =
- VERSION, etc. -} - VERSION, etc. -}
startExternal :: ExternalType -> Annex ExternalState startExternal :: ExternalType -> Annex ExternalState
startExternal externaltype = liftIO $ do startExternal externaltype = liftIO $ do
(Just hin, Just hout, _, pid) <- createProcess $ (Just hin, Just hout, _, pid) <- createProcess $ (proc cmd [])
(proc (externalRemoteProgram externaltype) [])
{ std_in = CreatePipe { std_in = CreatePipe
, std_out = CreatePipe , std_out = CreatePipe
, std_err = Inherit , std_err = Inherit
} }
fileEncoding hin fileEncoding hin
fileEncoding hout fileEncoding hout
checkearlytermination =<< getProcessExitCode pid
return $ ExternalState return $ ExternalState
{ externalSend = hin { externalSend = hin
, externalReceive = hout , externalReceive = hout
, externalPid = pid , externalPid = pid
, externalPrepared = False , externalPrepared = False
} }
where
cmd = externalRemoteProgram externaltype
checkearlytermination Nothing = noop
checkearlytermination (Just exitcode) = ifM (inPath cmd)
( error $ unwords [ "failed to run", cmd, "(" ++ show exitcode ++ ")" ]
, error $ cmd ++ " is not installed in PATH"
)
stopExternal :: External -> Annex () stopExternal :: External -> Annex ()
stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v) stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v)