external backends wip

It's able to start them up, the only thing not implemented is generating
and verifying keys. And, the key translation for HasExt.
This commit is contained in:
Joey Hess 2020-07-29 15:23:18 -04:00
parent b5d6a36db0
commit f75be32166
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
24 changed files with 482 additions and 136 deletions

View file

@ -13,8 +13,8 @@ import Git.Env
import Utility.Shell
import Messages.Progress
import Control.Concurrent.STM
import Control.Concurrent.Async
import System.Log.Logger (debugM)
data ExternalAddonProcess = ExternalAddonProcess
{ externalSend :: Handle
@ -23,6 +23,7 @@ data ExternalAddonProcess = ExternalAddonProcess
-- immediately.
, externalShutdown :: Bool -> IO ()
, externalPid :: ExternalAddonPID
, externalProgram :: String
}
type ExternalAddonPID = Int
@ -31,8 +32,8 @@ data ExternalAddonStartError
= ProgramNotInstalled String
| ProgramFailure String
startExternalAddonProcess :: String -> TVar ExternalAddonPID-> Annex (Either ExternalAddonStartError ExternalAddonProcess)
startExternalAddonProcess basecmd pidvar = do
startExternalAddonProcess :: String -> ExternalAddonPID -> Annex (Either ExternalAddonStartError ExternalAddonProcess)
startExternalAddonProcess basecmd pid = do
errrelayer <- mkStderrRelayer
g <- Annex.gitRepo
cmdpath <- liftIO $ searchPath basecmd
@ -47,16 +48,12 @@ startExternalAddonProcess basecmd pidvar = do
}
p <- propgit g basep
tryNonAsync (createProcess p) >>= \case
Right v -> (Right <$> started errrelayer v)
Right v -> (Right <$> started cmd errrelayer v)
`catchNonAsync` const (runerr cmdpath)
Left _ -> runerr cmdpath
started errrelayer pall@(Just hin, Just hout, Just herr, ph) = do
started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do
stderrelay <- async $ errrelayer herr
pid <- atomically $ do
n <- succ <$> readTVar pidvar
writeTVar pidvar n
return n
let shutdown forcestop = do
cancel stderrelay
if forcestop
@ -71,8 +68,9 @@ startExternalAddonProcess basecmd pidvar = do
, externalReceive = hout
, externalPid = pid
, externalShutdown = shutdown
, externalProgram = cmd
}
started _ _ = giveup "internal"
started _ _ _ = giveup "internal"
propgit g p = do
environ <- propGitEnv g
@ -85,3 +83,11 @@ startExternalAddonProcess basecmd pidvar = do
path <- intercalate ":" <$> getSearchPath
return $ Left $ ProgramNotInstalled $
"Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"
protocolDebug :: ExternalAddonProcess -> Bool -> String -> IO ()
protocolDebug external sendto line = debugM "external" $ unwords
[ externalProgram external ++
"[" ++ show (externalPid external) ++ "]"
, if sendto then "<--" else "-->"
, line
]