move externalConfig into ExternalState
Groundwork to having multiple processes running at once for an external special remote; each needs its own externalConfig.
This commit is contained in:
parent
63e21a607f
commit
b69dea0ac3
2 changed files with 29 additions and 20 deletions
|
@ -126,7 +126,9 @@ externalSetup mu _ c gc = do
|
||||||
INITREMOTE_SUCCESS -> Just noop
|
INITREMOTE_SUCCESS -> Just noop
|
||||||
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
|
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
liftIO $ atomically $ readTMVar $ externalConfig external
|
withExternalLock external $ \lck ->
|
||||||
|
fromExternal lck external externalConfig $
|
||||||
|
liftIO . atomically . readTMVar
|
||||||
|
|
||||||
gitConfigSpecialRemote u c'' "externaltype" externaltype
|
gitConfigSpecialRemote u c'' "externaltype" externaltype
|
||||||
return (c'', u)
|
return (c'', u)
|
||||||
|
@ -232,22 +234,26 @@ handleRequest' lck external req mp responsehandler
|
||||||
handleRemoteRequest (DIRHASH_LOWER k) =
|
handleRemoteRequest (DIRHASH_LOWER k) =
|
||||||
send $ VALUE $ hashDirLower def k
|
send $ VALUE $ hashDirLower def k
|
||||||
handleRemoteRequest (SETCONFIG setting value) =
|
handleRemoteRequest (SETCONFIG setting value) =
|
||||||
liftIO $ atomically $ do
|
fromExternal lck external externalConfig $ \v ->
|
||||||
let v = externalConfig external
|
liftIO $ atomically $ do
|
||||||
m <- takeTMVar v
|
m <- takeTMVar v
|
||||||
putTMVar v $ M.insert setting value m
|
putTMVar v $ M.insert setting value m
|
||||||
handleRemoteRequest (GETCONFIG setting) = do
|
handleRemoteRequest (GETCONFIG setting) = do
|
||||||
value <- fromMaybe "" . M.lookup setting
|
value <- fromExternal lck external externalConfig $ \v ->
|
||||||
<$> liftIO (atomically $ readTMVar $ externalConfig external)
|
fromMaybe "" . M.lookup setting
|
||||||
|
<$> liftIO (atomically $ readTMVar v)
|
||||||
send $ VALUE value
|
send $ VALUE value
|
||||||
handleRemoteRequest (SETCREDS setting login password) = do
|
handleRemoteRequest (SETCREDS setting login password) = do
|
||||||
c <- liftIO $ atomically $ readTMVar $ externalConfig external
|
fromExternal lck external externalConfig $ \v -> do
|
||||||
let gc = externalGitConfig external
|
c <- liftIO $ atomically $ readTMVar v
|
||||||
c' <- setRemoteCredPair encryptionAlreadySetup c gc (credstorage setting) $
|
let gc = externalGitConfig external
|
||||||
Just (login, password)
|
c' <- setRemoteCredPair encryptionAlreadySetup c gc
|
||||||
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
|
(credstorage setting)
|
||||||
|
(Just (login, password))
|
||||||
|
void $ liftIO $ atomically $ swapTMVar v c'
|
||||||
handleRemoteRequest (GETCREDS setting) = do
|
handleRemoteRequest (GETCREDS setting) = do
|
||||||
c <- liftIO $ atomically $ readTMVar $ externalConfig external
|
c <- fromExternal lck external externalConfig $
|
||||||
|
liftIO . atomically . readTMVar
|
||||||
let gc = externalGitConfig external
|
let gc = externalGitConfig external
|
||||||
creds <- fromMaybe ("", "") <$>
|
creds <- fromMaybe ("", "") <$>
|
||||||
getRemoteCredPair c gc (credstorage setting)
|
getRemoteCredPair c gc (credstorage setting)
|
||||||
|
@ -351,7 +357,7 @@ fromExternal lck external extractor a =
|
||||||
where
|
where
|
||||||
go (Just st) = run st
|
go (Just st) = run st
|
||||||
go Nothing = do
|
go Nothing = do
|
||||||
st <- startExternal $ externalType external
|
st <- startExternal external
|
||||||
void $ liftIO $ atomically $ do
|
void $ liftIO $ atomically $ do
|
||||||
void $ tryReadTMVar v
|
void $ tryReadTMVar v
|
||||||
putTMVar v st
|
putTMVar v st
|
||||||
|
@ -370,8 +376,8 @@ fromExternal lck external extractor a =
|
||||||
|
|
||||||
{- Starts an external remote process running, but does not handle checking
|
{- Starts an external remote process running, but does not handle checking
|
||||||
- VERSION, etc. -}
|
- VERSION, etc. -}
|
||||||
startExternal :: ExternalType -> Annex ExternalState
|
startExternal :: External -> Annex ExternalState
|
||||||
startExternal externaltype = do
|
startExternal external = do
|
||||||
errrelayer <- mkStderrRelayer
|
errrelayer <- mkStderrRelayer
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
|
@ -389,6 +395,7 @@ startExternal externaltype = do
|
||||||
fileEncoding herr
|
fileEncoding herr
|
||||||
stderrelay <- async $ errrelayer herr
|
stderrelay <- async $ errrelayer herr
|
||||||
checkearlytermination =<< getProcessExitCode pid
|
checkearlytermination =<< getProcessExitCode pid
|
||||||
|
cv <- atomically $ newTMVar $ externalDefaultConfig external
|
||||||
return $ ExternalState
|
return $ ExternalState
|
||||||
{ externalSend = hin
|
{ externalSend = hin
|
||||||
, externalReceive = hout
|
, externalReceive = hout
|
||||||
|
@ -396,9 +403,10 @@ startExternal externaltype = do
|
||||||
cancel stderrelay
|
cancel stderrelay
|
||||||
void $ waitForProcess pid
|
void $ waitForProcess pid
|
||||||
, externalPrepared = Unprepared
|
, externalPrepared = Unprepared
|
||||||
|
, externalConfig = cv
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
basecmd = externalRemoteProgram externaltype
|
basecmd = externalRemoteProgram $ externalType external
|
||||||
|
|
||||||
propgit g p = do
|
propgit g p = do
|
||||||
environ <- propGitEnv g
|
environ <- propGitEnv g
|
||||||
|
|
7
Remote/External/Types.hs
vendored
7
Remote/External/Types.hs
vendored
|
@ -52,8 +52,7 @@ data External = External
|
||||||
, externalState :: TMVar ExternalState
|
, externalState :: TMVar ExternalState
|
||||||
-- Empty when a remote is in use.
|
-- Empty when a remote is in use.
|
||||||
, externalLock :: TMVar ExternalLock
|
, externalLock :: TMVar ExternalLock
|
||||||
-- Never left empty.
|
, externalDefaultConfig :: RemoteConfig
|
||||||
, externalConfig :: TMVar RemoteConfig
|
|
||||||
, externalGitConfig :: RemoteGitConfig
|
, externalGitConfig :: RemoteGitConfig
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -63,7 +62,7 @@ newExternal externaltype u c gc = liftIO $ External
|
||||||
<*> pure u
|
<*> pure u
|
||||||
<*> atomically newEmptyTMVar
|
<*> atomically newEmptyTMVar
|
||||||
<*> atomically (newTMVar ExternalLock)
|
<*> atomically (newTMVar ExternalLock)
|
||||||
<*> atomically (newTMVar c)
|
<*> pure c
|
||||||
<*> pure gc
|
<*> pure gc
|
||||||
|
|
||||||
type ExternalType = String
|
type ExternalType = String
|
||||||
|
@ -73,6 +72,8 @@ data ExternalState = ExternalState
|
||||||
, externalReceive :: Handle
|
, externalReceive :: Handle
|
||||||
, externalShutdown :: IO ()
|
, externalShutdown :: IO ()
|
||||||
, externalPrepared :: PrepareStatus
|
, externalPrepared :: PrepareStatus
|
||||||
|
-- Never left empty.
|
||||||
|
, externalConfig :: TMVar RemoteConfig
|
||||||
}
|
}
|
||||||
|
|
||||||
data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg
|
data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue