From 7403aeb95f5d3b7b2ac2b763c7847900ef322eab Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 30 Jul 2025 14:46:37 -0400 Subject: [PATCH] use Annex.ExternalAddonProcess for P2P.Generic processes These are another sort of external addon process, and this makes several things work including shell scripts on windows. And it makes for nicer error messages when the command is not in the path. Note that the refactored startExternalAddonProcess used by this does not use propGitEnv to set git environment variables in the environment. Unlike startExternalAddonProcessProtocol which does. This is because it runs in IO and does not have access to that information. But also, I don't think that P2P.Generic processes need that. --- Annex/ExternalAddonProcess.hs | 57 ++++++++++++++++++++----------- P2P/Generic.hs | 63 ++++++++++++++++++++--------------- P2P/IO.hs | 3 +- 3 files changed, 75 insertions(+), 48 deletions(-) diff --git a/Annex/ExternalAddonProcess.hs b/Annex/ExternalAddonProcess.hs index 6e2af92d61..48ddf63625 100644 --- a/Annex/ExternalAddonProcess.hs +++ b/Annex/ExternalAddonProcess.hs @@ -33,6 +33,37 @@ data ExternalAddonStartError = ProgramNotInstalled String | ProgramFailure String +externalAddonStartErr :: Maybe OsPath -> String -> IO ExternalAddonStartError +externalAddonStartErr (Just cmd) _ = + return $ ProgramFailure $ + "Cannot run " ++ fromOsPath cmd ++ " -- Make sure it's executable and that its dependencies are installed." +externalAddonStartErr Nothing basecmd = do + path <- intercalate ":" . map fromOsPath <$> getSearchPath + return $ ProgramNotInstalled $ + "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")" + +startExternalAddonProcess + :: (CreateProcess -> CreateProcess) + -> String + -> [CommandParam] + -> IO (Either ExternalAddonStartError (String, (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))) +startExternalAddonProcess f basecmd ps = do + cmdpath <- searchPath basecmd + startExternalAddonProcess' cmdpath f basecmd ps + +startExternalAddonProcess' + :: Maybe OsPath + -> (CreateProcess -> CreateProcess) + -> String + -> [CommandParam] + -> IO (Either ExternalAddonStartError (String, (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))) +startExternalAddonProcess' cmdpath mkproc basecmd ps = do + (cmd, cmdps) <- maybe (pure (basecmd, [])) findShellCommand cmdpath + let p = mkproc (proc cmd (toCommand (cmdps ++ ps))) + tryNonAsync (createProcess p) >>= \case + Right v -> return (Right (cmd, v)) + Left _ -> Left <$> externalAddonStartErr cmdpath basecmd + -- | Starts an external addon process that speaks a protocol over stdio. startExternalAddonProcessProtocol :: String -> [CommandParam] -> ExternalAddonPID -> Annex (Either ExternalAddonStartError ExternalAddonProcess) startExternalAddonProcessProtocol basecmd ps pid = do @@ -42,17 +73,17 @@ startExternalAddonProcessProtocol basecmd ps pid = do liftIO $ start errrelayer g cmdpath where start errrelayer g cmdpath = do - (cmd, cmdps) <- maybe (pure (basecmd, [])) findShellCommand cmdpath - let basep = (proc cmd (toCommand (cmdps ++ ps))) + environ <- propGitEnv g + let mkproc = \p -> p { std_in = CreatePipe , std_out = CreatePipe , std_err = CreatePipe + , env = Just environ } - p <- propgit g basep - tryNonAsync (createProcess p) >>= \case - Right v -> (Right <$> started cmd errrelayer v) - `catchNonAsync` const (runerr cmdpath) - Left _ -> runerr cmdpath + startExternalAddonProcess' cmdpath mkproc basecmd ps >>= \case + Right (cmd, v) -> (Right <$> started cmd errrelayer v) + `catchNonAsync` const (Left <$> externalAddonStartErr cmdpath basecmd) + Left err -> return (Left err) started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do stderrelay <- async $ errrelayer ph herr @@ -80,18 +111,6 @@ startExternalAddonProcessProtocol basecmd ps pid = do } started _ _ _ = giveup "internal" - propgit g p = do - environ <- propGitEnv g - return $ p { env = Just environ } - - runerr (Just cmd) = - return $ Left $ ProgramFailure $ - "Cannot run " ++ fromOsPath cmd ++ " -- Make sure it's executable and that its dependencies are installed." - runerr Nothing = do - path <- intercalate ":" . map fromOsPath <$> getSearchPath - return $ Left $ ProgramNotInstalled $ - "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")" - protocolDebug :: ExternalAddonProcess -> Bool -> String -> IO () protocolDebug external sendto line = debug "Annex.ExternalAddonProcess" $ unwords [ externalProgram external ++ diff --git a/P2P/Generic.hs b/P2P/Generic.hs index ac80f3eedf..5399fb6429 100644 --- a/P2P/Generic.hs +++ b/P2P/Generic.hs @@ -11,42 +11,51 @@ module P2P.Generic where import Common import P2P.Address +import Annex.ExternalAddonProcess genericP2PCommand :: P2PNetName -> String genericP2PCommand (P2PNetName netname) = "git-annex-p2p-" ++ netname -connectGenericP2P :: P2PNetName -> UnderlyingP2PAddress -> CreateProcess +connectGenericP2P :: P2PNetName -> UnderlyingP2PAddress -> IO (Handle, Handle, ProcessHandle) connectGenericP2P netname (UnderlyingP2PAddress address) = - (proc (genericP2PCommand netname) [address]) - { std_in = CreatePipe - , std_out = CreatePipe - } - -socketGenericP2P :: P2PNetName -> UnderlyingP2PAddress -> CreateProcess -socketGenericP2P netname (UnderlyingP2PAddress address) = - (proc (genericP2PCommand netname) ["socket", address]) - { std_out = CreatePipe - } - -addressGenericP2P :: P2PNetName -> CreateProcess -addressGenericP2P netname = - (proc (genericP2PCommand netname) ["address"]) - { std_out = CreatePipe - } + startExternalAddonProcess + (\p -> p + { std_in = CreatePipe + , std_out = CreatePipe + }) + (genericP2PCommand netname) [Param address] + >>= \case + Right (_, (Just hin, Just hout, Nothing, pid)) -> + return (hin, hout, pid) + Right _ -> giveup "internal" + Left (ProgramNotInstalled msg) -> giveup msg + Left (ProgramFailure msg) -> giveup msg getSocketGenericP2P :: P2PNetName -> UnderlyingP2PAddress -> IO (Maybe (OsPath, ProcessHandle)) -getSocketGenericP2P netname address = do - (Nothing, Just hin, Nothing, pid) <- createProcess $ - socketGenericP2P netname address - hGetLineUntilExitOrEOF pid hin >>= \case - Just l | not (null l) -> return $ Just (toOsPath l, pid) - _ -> return Nothing +getSocketGenericP2P netname (UnderlyingP2PAddress address) = do + startExternalAddonProcess + (\p -> p { std_out = CreatePipe }) + (genericP2PCommand netname) [Param "socket", Param address] + >>= \case + Right (_, (Nothing, Just hin, Nothing, pid)) -> + hGetLineUntilExitOrEOF pid hin >>= \case + Just l | not (null l) -> return $ Just (toOsPath l, pid) + _ -> return Nothing + Right _ -> giveup "internal" + Left (ProgramNotInstalled msg) -> giveup msg + Left (ProgramFailure msg) -> giveup msg getAddressGenericP2P :: P2PNetName -> IO [P2PAddress] -getAddressGenericP2P netname = do - (Nothing, Just hin, Nothing, pid) <- createProcess $ - addressGenericP2P netname - go [] hin pid +getAddressGenericP2P netname = + startExternalAddonProcess + (\p -> p { std_out = CreatePipe }) + (genericP2PCommand netname) [Param "address"] + >>= \case + Right (_, (Nothing, Just hin, Nothing, pid)) -> + go [] hin pid + Right _ -> giveup "internal" + Left (ProgramNotInstalled msg) -> giveup msg + Left (ProgramFailure msg) -> giveup msg where go addrs hin pid = hGetLineUntilExitOrEOF pid hin >>= \case Just l diff --git a/P2P/IO.hs b/P2P/IO.hs index bc3bc61745..95e5cb43b3 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -148,8 +148,7 @@ connectPeer g (TorAnnex onionaddress onionport) = do , connIdent = ConnIdent Nothing } connectPeer g (P2PAnnex netname address) = do - (Just hin, Just hout, Nothing, pid) <- createProcess $ - connectGenericP2P netname address + (hin, hout, pid) <- connectGenericP2P netname address return $ P2PConnection { connRepo = g , connCheckAuth = const False -- 2.30.2