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:
Joey Hess 2016-09-30 13:36:50 -04:00
parent 63e21a607f
commit b69dea0ac3
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
2 changed files with 29 additions and 20 deletions

View file

@ -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

View file

@ -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