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.

diff --git a/Annex/ExternalAddonProcess.hs b/Annex/ExternalAddonProcess.hs
index 6e2af92d617c05ce33be24f453a080f5327f4ea6..48ddf63625bfb05102632f6ac90208dbb2959a67 100644 (file)
--- 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 ac80f3eedfe8a3df25cc285edae340e39fc59a70..5399fb642987c197679933432774c8935ba68db5 100644 (file)
--- 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 bc3bc617457097eaf083781df7ece9c738fec077..95e5cb43b3b94729609b1e0e834f6b6ed59d9ad7 100644 (file)
--- 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