From 8af6d2c3c57d8ef171751bba8363e884f71c296a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 26 Feb 2020 17:20:56 -0400 Subject: [PATCH 1/3] fix encryption of content to gcrypt and git-lfs Fix serious regression in gcrypt and encrypted git-lfs remotes. Since version 7.20200202.7, git-annex incorrectly stored content on those remotes without encrypting it. Problem was, Remote.Git enumerates all git remotes, including git-lfs and gcrypt. It then dispatches to those. So, Remote.List used the RemoteConfigParser from Remote.Git, instead of from git-lfs or gcrypt, and that parser does not know about encryption fields, so did not include them in the ParsedRemoteConfig. (Also didn't include other fields specific to those remotes, perhaps chunking etc also didn't get through.) To fix, had to move RemoteConfig parsing down into the generate methods of each remote, rather than doing it in Remote.List. And a consequence of that was that ParsedRemoteConfig had to change to include the RemoteConfig that got parsed, so that testremote can generate a new remote based on an existing remote. (I would have rather fixed this just inside Remote.Git, but that was not practical, at least not w/o re-doing work that Remote.List already did. Big ugly mostly mechanical patch seemed preferable to making git-annex slower.) --- Annex/SpecialRemote/Config.hs | 30 +++++++++++++++++------ Assistant/WebApp/Configurators/AWS.hs | 3 +-- Assistant/WebApp/Configurators/Edit.hs | 6 ++--- Assistant/WebApp/Configurators/WebDAV.hs | 5 ++-- CHANGELOG | 12 +++++++++ Command/TestRemote.hs | 21 ++++++++-------- Creds.hs | 11 +++++---- NEWS | 15 ++++++++++++ Remote/Adb.hs | 5 ++-- Remote/BitTorrent.hs | 6 +++-- Remote/Bup.hs | 13 +++++----- Remote/Ddar.hs | 17 +++++++------ Remote/Directory.hs | 7 +++--- Remote/External.hs | 31 ++++++++++++++---------- Remote/GCrypt.hs | 20 +++++++-------- Remote/Git.hs | 19 ++++++++------- Remote/GitLFS.hs | 19 ++++++++------- Remote/Glacier.hs | 16 ++++++------ Remote/Helper/Encryptable.hs | 2 +- Remote/Helper/ExportImport.hs | 20 +++------------ Remote/Hook.hs | 7 +++--- Remote/List.hs | 4 +-- Remote/P2P.hs | 6 +++-- Remote/Rsync.hs | 12 ++++----- Remote/S3.hs | 15 ++++++------ Remote/Tahoe.hs | 5 ++-- Remote/Web.hs | 6 +++-- Remote/WebDAV.hs | 10 +++++--- Test.hs | 4 +-- Types/Remote.hs | 2 +- Types/RemoteConfig.hs | 4 ++- 31 files changed, 202 insertions(+), 151 deletions(-) diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs index d4f8da22a8..2db6a0d033 100644 --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -11,7 +11,8 @@ module Annex.SpecialRemote.Config where import Common -import Types.Remote (RemoteConfigField, RemoteConfig) +import Types.Remote (RemoteConfigField, RemoteConfig, configParser) +import Types import Types.UUID import Types.ProposedAccepted import Types.RemoteConfig @@ -106,6 +107,10 @@ commonFieldParsers = (FieldDesc "type of special remote") , trueFalseParser autoEnableField False (FieldDesc "automatically enable special remote") + , yesNoParser exportTreeField False + (FieldDesc "export trees of files to this remote") + , yesNoParser importTreeField False + (FieldDesc "import trees of files from this remote") , optionalStringParser preferreddirField (FieldDesc "directory whose content is preferred") ] @@ -162,7 +167,7 @@ findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toLis {- Extracts a value from ParsedRemoteConfig. -} getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v -getRemoteConfigValue f m = case M.lookup f m of +getRemoteConfigValue f (ParsedRemoteConfig m _) = case M.lookup f m of Just (RemoteConfigValue v) -> case cast v of Just v' -> Just v' Nothing -> error $ unwords @@ -176,13 +181,20 @@ getRemoteConfigValue f m = case M.lookup f m of {- Gets all fields that remoteConfigRestPassthrough matched. -} getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String -getRemoteConfigPassedThrough = M.mapMaybe $ \(RemoteConfigValue v) -> - case cast v of - Just (PassedThrough s) -> Just s - Nothing -> Nothing +getRemoteConfigPassedThrough (ParsedRemoteConfig m _) = + flip M.mapMaybe m $ \(RemoteConfigValue v) -> + case cast v of + Just (PassedThrough s) -> Just s + Nothing -> Nothing newtype PassedThrough = PassedThrough String +parsedRemoteConfig :: RemoteType -> RemoteConfig -> Annex ParsedRemoteConfig +parsedRemoteConfig t c = either (const emptycfg) id . parseRemoteConfig c + <$> configParser t c + where + emptycfg = ParsedRemoteConfig mempty c + parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig parseRemoteConfig c rpc = go [] c (remoteConfigFieldParsers rpc ++ commonFieldParsers) @@ -195,8 +207,10 @@ parseRemoteConfig c rpc = in if not (null leftovers') then Left $ "Unexpected parameters: " ++ unwords (map (fromProposedAccepted . fst) leftovers') - else Right $ M.fromList $ - l ++ map (uncurry passthrough) passover + else + let m = M.fromList $ + l ++ map (uncurry passthrough) passover + in Right (ParsedRemoteConfig m c) go l c' (p:rest) = do let f = parserForField p (valueParser p) (M.lookup f c) c >>= \case diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index 92717bfe64..e41236eed1 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -170,8 +170,7 @@ getEnableS3R uuid = do m <- liftAnnex readRemoteLog isia <- case M.lookup uuid m of Just c -> liftAnnex $ do - pc <- either mempty id . parseRemoteConfig c - <$> Remote.configParser S3.remote c + pc <- parsedRemoteConfig S3.remote c return $ S3.configIA pc Nothing -> return False if isia diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 93a45ef7a9..16a375ac82 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -256,8 +256,7 @@ getRepoInfo :: Maybe Remote.Remote -> Remote.RemoteConfig -> Widget getRepoInfo (Just r) c = case fromProposedAccepted <$> M.lookup typeField c of Just "S3" -> do #ifdef WITH_S3 - pc <- liftAnnex $ either mempty id . parseRemoteConfig c - <$> Remote.configParser S3.remote c + pc <- liftAnnex $ parsedRemoteConfig S3.remote c if S3.configIA pc then IA.getRepoInfo c else AWS.getRepoInfo c @@ -283,7 +282,8 @@ getRepoEncryption (Just _) (Just c) = case extractCipher pc of (Just (EncryptedCipher _ _ ks)) -> desckeys ks (Just (SharedPubKeyCipher _ ks)) -> desckeys ks where - pc = either mempty id $ parseEncryptionConfig c + pc = either (const (Remote.ParsedRemoteConfig mempty mempty)) id $ + parseEncryptionConfig c desckeys (KeyIds { keyIds = ks }) = do cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig knownkeys <- liftIO (secretKeys cmd) diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 37ff804557..0dc778b867 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -15,7 +15,7 @@ import Creds import qualified Remote.WebDAV as WebDAV import Assistant.WebApp.MakeRemote import qualified Remote -import Types.Remote (RemoteConfig, configParser) +import Types.Remote (RemoteConfig) import Types.StandardGroups import Logs.Remote import Git.Types (RemoteName) @@ -62,8 +62,7 @@ postEnableWebDAVR uuid = do let url = fromProposedAccepted $ fromJust $ M.lookup (Accepted "url") c mcreds <- liftAnnex $ do dummycfg <- liftIO dummyRemoteGitConfig - pc <- either mempty id . parseRemoteConfig c - <$> configParser WebDAV.remote c + pc <- parsedRemoteConfig WebDAV.remote c getRemoteCredPairFor "webdav" pc dummycfg (WebDAV.davCreds uuid) case mcreds of Just creds -> webDAVConfigurator $ liftH $ diff --git a/CHANGELOG b/CHANGELOG index 43518f25f4..865043651b 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,15 @@ +git-annex (7.20200226) upstream; urgency=high + + * Fix serious regression in gcrypt and encrypted git-lfs remotes. + Since version 7.20200202.7, git-annex incorrectly stored content + on those remotes without encrypting it. + If your remotes are affected, you will want to make sure to delete + any content that git-annex has stored on them that is not encrypted! + * info: Fix display of the encryption value. + (Some debugging junk had crept in.) + + -- Joey Hess Wed, 26 Feb 2020 17:18:16 -0400 + git-annex (7.20200219) upstream; urgency=medium * Added sync --only-annex, which syncs the git-annex branch and annexed diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 7e56e25181..9ccc1f31c1 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -24,8 +24,8 @@ import Utility.DataUnits import Utility.CopyFile import Types.Messages import Types.Export -import Types.Crypto import Types.RemoteConfig +import Types.ProposedAccepted import Annex.SpecialRemote.Config (exportTreeField) import Remote.Helper.ExportImport import Remote.Helper.Chunked @@ -122,18 +122,18 @@ perform rs unavailrs exportr ks = do ] adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) -adjustChunkSize r chunksize = adjustRemoteConfig r - (M.insert chunkField (RemoteConfigValue (show chunksize))) +adjustChunkSize r chunksize = adjustRemoteConfig r $ + M.insert chunkField (Proposed (show chunksize)) -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested. encryptionVariants :: Remote -> Annex [Remote] encryptionVariants r = do noenc <- adjustRemoteConfig r $ - M.insert encryptionField (RemoteConfigValue NoneEncryption) + M.insert encryptionField (Proposed "none") sharedenc <- adjustRemoteConfig r $ - M.insert encryptionField (RemoteConfigValue SharedEncryption) . - M.insert highRandomQualityField (RemoteConfigValue False) + M.insert encryptionField (Proposed "shared") . + M.insert highRandomQualityField (Proposed "false") return $ catMaybes [noenc, sharedenc] -- Variant of a remote with exporttree disabled. @@ -145,19 +145,20 @@ disableExportTree r = maybe (error "failed disabling exportree") return exportTreeVariant :: Remote -> Annex (Maybe Remote) exportTreeVariant r = ifM (Remote.isExportSupported r) ( adjustRemoteConfig r $ - M.insert encryptionField (RemoteConfigValue NoneEncryption) . - M.insert exportTreeField (RemoteConfigValue True) + M.insert encryptionField (Proposed "none") . + M.insert exportTreeField (Proposed "yes") , return Nothing ) -- Regenerate a remote with a modified config. -adjustRemoteConfig :: Remote -> (Remote.ParsedRemoteConfig -> Remote.ParsedRemoteConfig) -> Annex (Maybe Remote) +adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote) adjustRemoteConfig r adjustconfig = do repo <- Remote.getRepo r + let ParsedRemoteConfig _ origc = Remote.config r Remote.generate (Remote.remotetype r) repo (Remote.uuid r) - (adjustconfig (Remote.config r)) + (adjustconfig origc) (Remote.gitconfig r) (Remote.remoteStateHandle r) diff --git a/Creds.hs b/Creds.hs index ef05982ca6..766cf709b4 100644 --- a/Creds.hs +++ b/Creds.hs @@ -57,8 +57,9 @@ data CredPairStorage = CredPairStorage - cipher. The EncryptionIsSetup is witness to that being the case. -} setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig -setRemoteCredPair = setRemoteCredPair' id - (either (const mempty) id . parseEncryptionConfig) +setRemoteCredPair = setRemoteCredPair' id go + where + go c = either (const (ParsedRemoteConfig mempty c)) id (parseEncryptionConfig c) setRemoteCredPair' :: (ProposedAccepted String -> a) @@ -203,18 +204,18 @@ removeCreds file = do liftIO $ nukeFile f includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] -includeCredsInfo c storage info = do +includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do v <- liftIO $ getEnvCredPair storage case v of Just _ -> do let (uenv, penv) = credPairEnvironment storage ret $ "from environment variables (" ++ unwords [uenv, penv] ++ ")" - Nothing -> case (`M.lookup` c) (credPairRemoteField storage) of + Nothing -> case (`M.lookup` cm) (credPairRemoteField storage) of Nothing -> ifM (existsCacheCredPair storage) ( ret "stored locally" , ret "not available" ) - Just _ -> case extractCipher c of + Just _ -> case extractCipher pc of Just (EncryptedCipher {}) -> ret "embedded in git repository (gpg encrypted)" _ -> ret "embedded in git repository (not encrypted)" where diff --git a/NEWS b/NEWS index df2f7612ba..a80f45f12c 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,18 @@ +git-annex (7.20200226) upstream; urgency=high + + There was a serious regression in gcrypt and encrypted git-lfs remotes. + Since version 7.20200202.7, git-annex incorrectly stored content + on those remotes without encrypting it. + + If your remotes are affected, you will want to make sure to delete + any content that git-annex has stored on them that is not encrypted! + + One way to do so is, before upgrading to this version, + run git-annex move --from the affected remotes. It will move + only the content that was not encrypted. + + -- Joey Hess Wed, 26 Feb 2020 17:18:16 -0400 + git-annex (7.20191024) upstream; urgency=medium When annex.largefiles is not configured, `git add` and `git commit -a` diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 4468c8ee94..9311cb4451 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -54,8 +54,9 @@ androiddirectoryField = Accepted "androiddirectory" androidserialField :: RemoteConfigField androidserialField = Accepted "androidserial" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc let this = Remote { uuid = u -- adb operates over USB or wifi, so is not as cheap diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 9c1b96a05d..245081cf2e 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -28,6 +28,7 @@ import Annex.Tmp import Annex.UUID import qualified Annex.Url as Url import Remote.Helper.ExportImport +import Annex.SpecialRemote.Config import Network.URI @@ -53,9 +54,10 @@ list _autoinit = do r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown) return [r] -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r _ c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r _ rc gc rs = do cst <- remoteCost gc expensiveRemoteCost + c <- parsedRemoteConfig remote rc return $ Just Remote { uuid = bitTorrentUUID , cost = cst diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 21d3eb0097..005a8a89f4 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -55,8 +55,9 @@ remote = specialRemoteType $ RemoteType buprepoField :: RemoteConfigField buprepoField = Accepted "buprepo" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc bupr <- liftIO $ bup2GitRemote buprepo cst <- remoteCost gc $ if bupLocal buprepo @@ -99,6 +100,10 @@ gen r u c gc rs = do , checkUrl = Nothing , remoteStateHandle = rs } + let specialcfg = (specialRemoteCfg c) + -- chunking would not improve bup + { chunkConfig = NoChunks + } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this buprepo) (simplyPrepare $ retrieve buprepo) @@ -107,10 +112,6 @@ gen r u c gc rs = do this where buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc - specialcfg = (specialRemoteCfg c) - -- chunking would not improve bup - { chunkConfig = NoChunks - } bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) bupSetup _ mu _ c gc = do diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 29f3f5bf52..c8847e1f94 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -48,20 +48,25 @@ remote = specialRemoteType $ RemoteType ddarrepoField :: RemoteConfigField ddarrepoField = Accepted "ddarrepo" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc $ if ddarLocal ddarrepo then nearlyCheapRemoteCost else expensiveRemoteCost + let specialcfg = (specialRemoteCfg c) + -- chunking would not improve ddar + { chunkConfig = NoChunks + } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store ddarrepo) (simplyPrepare $ retrieve ddarrepo) (simplyPrepare $ remove ddarrepo) (simplyPrepare $ checkKey ddarrepo) - (this cst) + (this c cst) where - this cst = Remote + this c cst = Remote { uuid = u , cost = cst , name = Git.repoDescribe r @@ -97,10 +102,6 @@ gen r u c gc rs = do , remoteStateHandle = rs } ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc) - specialcfg = (specialRemoteCfg c) - -- chunking would not improve ddar - { chunkConfig = NoChunks - } ddarSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) ddarSetup _ mu _ c gc = do diff --git a/Remote/Directory.hs b/Remote/Directory.hs index e9162080ce..bf83cc8476 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -54,8 +54,9 @@ remote = specialRemoteType $ RemoteType directoryField :: RemoteConfigField directoryField = Accepted "directory" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc cheapRemoteCost let chunkconfig = getChunkConfig c return $ Just $ specialRemote c @@ -106,7 +107,7 @@ gen r u c gc rs = do , appendonly = False , availability = LocallyAvailable , remotetype = remote - , mkUnavailable = gen r u c + , mkUnavailable = gen r u rc (gc { remoteAnnexDirectory = Just "/dev/null" }) rs , getInfo = return [("directory", dir)] , claimUrl = Nothing diff --git a/Remote/External.hs b/Remote/External.hs index 750e6ed773..d66629c002 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -62,12 +62,13 @@ externaltypeField = Accepted "externaltype" readonlyField :: RemoteConfigField readonlyField = Accepted "readonly" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs -- readonly mode only downloads urls; does not use external program | remoteAnnexReadOnly gc = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost - mk cst GloballyAvailable + mk c cst GloballyAvailable readonlyStorer retrieveUrl readonlyRemoveKey @@ -79,6 +80,7 @@ gen r u c gc rs exportUnsupported exportUnsupported | otherwise = do + c <- parsedRemoteConfig remote rc external <- newExternal externaltype (Just u) c (Just gc) (Just rs) Annex.addCleanup (RemoteCleanup u) $ stopExternal external cst <- getCost external r gc @@ -101,7 +103,7 @@ gen r u c gc rs let cheapexportsupported = if exportsupported then exportIsSupported else exportUnsupported - mk cst avail + mk c cst avail (storeKeyM external) (retrieveKeyFileM external) (removeKeyM external) @@ -113,7 +115,7 @@ gen r u c gc rs exportactions cheapexportsupported where - mk cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do + mk c cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do let rmt = Remote { uuid = u , cost = cst @@ -144,7 +146,7 @@ gen r u c gc rs , availability = avail , remotetype = remote { exportSupported = cheapexportsupported } - , mkUnavailable = gen r u c + , mkUnavailable = gen r u rc (gc { remoteAnnexExternalType = Just "!dne!" }) rs , getInfo = togetinfo , claimUrl = toclaimurl @@ -409,25 +411,28 @@ handleRequest' st external req mp responsehandler send $ VALUE $ fromRawFilePath $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) = liftIO $ atomically $ do - modifyTVar' (externalConfig st) $ - M.insert (Accepted setting) $ - RemoteConfigValue (PassedThrough value) + modifyTVar' (externalConfig st) $ \(ParsedRemoteConfig m c) -> + let m' = M.insert + (Accepted setting) + (RemoteConfigValue (PassedThrough value)) + m + in ParsedRemoteConfig m' c modifyTVar' (externalConfigChanges st) $ \f -> f . M.insert (Accepted setting) (Accepted value) handleRemoteRequest (GETCONFIG setting) = do value <- fromMaybe "" - . M.lookup (Accepted setting) + . (M.lookup (Accepted setting)) . getRemoteConfigPassedThrough <$> liftIO (atomically $ readTVar $ externalConfig st) send $ VALUE value handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of (Just u, Just gc) -> do let v = externalConfig st - c <- liftIO $ atomically $ readTVar v - c' <- setRemoteCredPair' RemoteConfigValue id encryptionAlreadySetup c gc + (ParsedRemoteConfig m c) <- liftIO $ atomically $ readTVar v + m' <- setRemoteCredPair' RemoteConfigValue (\m' -> ParsedRemoteConfig m' c) encryptionAlreadySetup m gc (credstorage setting u) (Just (login, password)) - void $ liftIO $ atomically $ swapTVar v c' + void $ liftIO $ atomically $ swapTVar v (ParsedRemoteConfig m' c) _ -> senderror "cannot send SETCREDS here" handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of (Just u, Just gc) -> do diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 3f19070095..9e2d0891ae 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -80,16 +80,16 @@ remote = specialRemoteType $ RemoteType gitRepoField :: RemoteConfigField gitRepoField = Accepted "gitrepo" -chainGen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -chainGen gcryptr u c gc rs = do +chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +chainGen gcryptr u rc gc rs = do g <- gitRepo -- get underlying git repo with real path, not gcrypt path r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr let r' = r { Git.remoteName = Git.remoteName gcryptr } - gen r' u c gc rs + gen r' u rc gc rs -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen baser u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen baser u rc gc rs = do -- doublecheck that cache matches underlying repo's gcrypt-id -- (which might not be set), only for local repos (mgcryptid, r) <- getGCryptId True baser gc @@ -97,7 +97,9 @@ gen baser u c gc rs = do case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName baser)) of (Just gcryptid, Just cachedgcryptid) | gcryptid /= cachedgcryptid -> resetup gcryptid r - _ -> gen' r u c gc rs + _ -> do + c <- parsedRemoteConfig remote rc + gen' r u c gc rs where -- A different drive may have been mounted, making a different -- gcrypt remote available. So need to set the cached @@ -108,10 +110,8 @@ gen baser u c gc rs = do let u' = genUUIDInNameSpace gCryptNameSpace gcryptid v <- M.lookup u' <$> readRemoteLog case (Git.remoteName baser, v) of - (Just remotename, Just c') -> do - pc <- either giveup return - . parseRemoteConfig c' - =<< configParser remote c' + (Just remotename, Just rc') -> do + pc <- parsedRemoteConfig remote rc' setGcryptEncryption pc remotename storeUUIDIn (remoteConfig baser "uuid") u' setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid diff --git a/Remote/Git.hs b/Remote/Git.hs index ca7edc383b..afce528039 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -161,20 +161,21 @@ configRead autoinit r = do Just r' -> return r' _ -> return r -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs -- Remote.GitLFS may be used with a repo that is also encrypted -- with gcrypt so is checked first. - | remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc rs - | Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc rs + | remoteAnnexGitLFS gc = Remote.GitLFS.gen r u rc gc rs + | Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u rc gc rs | otherwise = case repoP2PAddress r of Nothing -> do st <- mkState r u gc - go st <$> remoteCost gc defcst - Just addr -> Remote.P2P.chainGen addr r u c gc rs + c <- parsedRemoteConfig remote rc + go st c <$> remoteCost gc defcst + Just addr -> Remote.P2P.chainGen addr r u rc gc rs where defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost - go st cst = Just new + go st c cst = Just new where new = Remote { uuid = u @@ -205,14 +206,14 @@ gen r u c gc rs , appendonly = False , availability = availabilityCalc r , remotetype = remote - , mkUnavailable = unavailable r u c gc rs + , mkUnavailable = unavailable r u rc gc rs , getInfo = gitRepoInfo new , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs } -unavailable :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) unavailable r = gen r' where r' = case Git.location r of diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 2f91d1c77a..9e94f9fd03 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -73,8 +73,9 @@ remote = specialRemoteType $ RemoteType urlField :: RemoteConfigField urlField = Accepted "url" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc -- If the repo uses gcrypt, get the underlaying repo without the -- gcrypt url, to do LFS endpoint discovery on. r' <- if Git.GCrypt.isEncrypted r @@ -85,14 +86,18 @@ gen r u c gc rs = do sem <- liftIO $ MSemN.new 1 h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc cst <- remoteCost gc expensiveRemoteCost + let specialcfg = (specialRemoteCfg c) + -- chunking would not improve git-lfs + { chunkConfig = NoChunks + } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store rs h) (simplyPrepare $ retrieve rs h) (simplyPrepare $ remove h) (simplyPrepare $ checkKey rs h) - (this cst) + (this c cst) where - this cst = Remote + this c cst = Remote { uuid = u , cost = cst , name = Git.repoDescribe r @@ -122,15 +127,11 @@ gen r u c gc rs = do -- content cannot be removed from a git-lfs repo , appendonly = True , mkUnavailable = return Nothing - , getInfo = gitRepoInfo (this cst) + , getInfo = gitRepoInfo (this c cst) , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs } - specialcfg = (specialRemoteCfg c) - -- chunking would not improve git-lfs - { chunkConfig = NoChunks - } mySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) mySetup _ mu _ c gc = do diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index b422e4f35d..4c758d65be 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -59,10 +59,12 @@ vaultField = Accepted "vault" fileprefixField :: RemoteConfigField fileprefixField = Accepted "fileprefix" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = new + <$> parsedRemoteConfig remote rc + <*> remoteCost gc veryExpensiveRemoteCost where - new cst = Just $ specialRemote' specialcfg c + new c cst = Just $ specialRemote' specialcfg c (prepareStore this) (prepareRetrieve this) (simplyPrepare $ remove this) @@ -105,10 +107,10 @@ gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost , checkUrl = Nothing , remoteStateHandle = rs } - specialcfg = (specialRemoteCfg c) - -- Disabled until jobList gets support for chunks. - { chunkConfig = NoChunks - } + specialcfg = (specialRemoteCfg c) + -- Disabled until jobList gets support for chunks. + { chunkConfig = NoChunks + } glacierSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) glacierSetup ss mu mcreds c gc = do diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 33ef848bb7..e4ae10b352 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -284,7 +284,7 @@ isEncrypted = isJust . extractCipher describeEncryption :: ParsedRemoteConfig -> String describeEncryption c = case extractCipher c of - Nothing -> "none" ++ show (getRemoteConfigValue cipherField c :: Maybe String) ++ show (M.keys c) + Nothing -> "none" Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")" nameCipher :: StorableCipher -> String diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index a412f143fe..78b0c05cba 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -72,15 +72,11 @@ importIsSupported = \_ _ -> return True -- | Prevent or allow exporttree=yes and importtree=yes when -- setting up a new remote, depending on exportSupported and importSupported. adjustExportImportRemoteType :: RemoteType -> RemoteType -adjustExportImportRemoteType rt = rt - { setup = setup' - , configParser = configparser - } +adjustExportImportRemoteType rt = rt { setup = setup' } where - configparser c = addRemoteConfigParser exportImportConfigParsers - <$> configParser rt c setup' st mu cp c gc = do - pc <- either giveup return . parseRemoteConfig c =<< configparser c + pc <- either giveup return . parseRemoteConfig c + =<< configParser rt c let checkconfig supported configured configfield cont = ifM (supported rt pc gc) ( case st of @@ -89,7 +85,7 @@ adjustExportImportRemoteType rt = rt giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield | otherwise -> cont Enable oldc -> do - oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser oldc + oldpc <- parsedRemoteConfig rt oldc if configured pc /= configured oldpc then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote" else cont @@ -103,14 +99,6 @@ adjustExportImportRemoteType rt = rt then giveup "cannot enable importtree=yes without also enabling exporttree=yes" else setup rt st mu cp c gc -exportImportConfigParsers :: [RemoteConfigFieldParser] -exportImportConfigParsers = - [ yesNoParser exportTreeField False - (FieldDesc "export trees of files to this remote") - , yesNoParser importTreeField False - (FieldDesc "import trees of files from this remote") - ] - -- | Adjust a remote to support exporttree=yes and importree=yes. -- -- Note that all remotes with importree=yes also have exporttree=yes. diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 2fab096c03..71c06de3a2 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -45,8 +45,9 @@ remote = specialRemoteType $ RemoteType hooktypeField :: RemoteConfigField hooktypeField = Accepted "hooktype" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost return $ Just $ specialRemote c (simplyPrepare $ store hooktype) @@ -80,7 +81,7 @@ gen r u c gc rs = do , appendonly = False , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u c + , mkUnavailable = gen r u rc (gc { remoteAnnexHookType = Just "!dne!" }) rs , getInfo = return [("hooktype", hooktype)] diff --git a/Remote/List.hs b/Remote/List.hs index 4619df6345..c763170497 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -20,7 +20,6 @@ import Annex.UUID import Remote.Helper.Hooks import Remote.Helper.ReadOnly import Remote.Helper.ExportImport -import Annex.SpecialRemote.Config import qualified Git import qualified Git.Config @@ -110,8 +109,7 @@ remoteGen m t g = do let cu = fromMaybe u $ remoteAnnexConfigUUID gc let rs = RemoteStateHandle cu let c = fromMaybe M.empty $ M.lookup cu m - pc <- either (const mempty) id . parseRemoteConfig c <$> configParser t c - generate t g u pc gc rs >>= \case + generate t g u c gc rs >>= \case Nothing -> return Nothing Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs diff --git a/Remote/P2P.hs b/Remote/P2P.hs index be90ce55f6..009bca6e77 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -26,6 +26,7 @@ import Remote.Helper.Git import Remote.Helper.ExportImport import Remote.Helper.P2P import Utility.AuthToken +import Annex.SpecialRemote.Config import Control.Concurrent.STM @@ -42,8 +43,9 @@ remote = RemoteType , importSupported = importUnsupported } -chainGen :: P2PAddress -> Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -chainGen addr r u c gc rs = do +chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +chainGen addr r u rc gc rs = do + c <- parsedRemoteConfig remote rc connpool <- mkConnectionPool cst <- remoteCost gc veryExpensiveRemoteCost let protorunner = runProto u addr connpool diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index fadc816912..b19bbbe78b 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -67,13 +67,17 @@ shellEscapeField = Accepted "shellescape" rsyncUrlField :: RemoteConfigField rsyncUrlField = Accepted "rsyncurl" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost (transport, url) <- rsyncTransport gc $ fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc let o = genRsyncOpts c gc transport url let islocal = rsyncUrlIsPath $ rsyncUrl o + let specialcfg = (specialRemoteCfg c) + -- Rsync displays its own progress. + { displayProgress = False } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ fileStorer $ store o) (simplyPrepare $ fileRetriever $ retrieve o) @@ -119,10 +123,6 @@ gen r u c gc rs = do , checkUrl = Nothing , remoteStateHandle = rs } - where - specialcfg = (specialRemoteCfg c) - -- Rsync displays its own progress. - { displayProgress = False } -- Things used by genRsyncOpts rsyncRemoteConfigs :: [RemoteConfigFieldParser] diff --git a/Remote/S3.hs b/Remote/S3.hs index ff5484464d..5a45403acd 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -154,15 +154,16 @@ portField = Accepted "port" mungekeysField :: RemoteConfigField mungekeysField = Accepted "mungekeys" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost info <- extractS3Info c hdl <- mkS3HandleVar c gc u magic <- liftIO initMagicMime - return $ new cst info hdl magic + return $ new c cst info hdl magic where - new cst info hdl magic = Just $ specialRemote c + new c cst info hdl magic = Just $ specialRemote c (simplyPrepare $ store hdl this info magic) (simplyPrepare $ retrieve hdl this rs c info) (simplyPrepare $ remove hdl this info) @@ -211,7 +212,7 @@ gen r u c gc rs = do , appendonly = versioning info , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u (M.insert hostField (RemoteConfigValue ("!dne!" :: String)) c) gc rs + , mkUnavailable = gen r u (M.insert hostField (Proposed "!dne!") rc) gc rs , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info) , claimUrl = Nothing , checkUrl = Nothing @@ -1251,9 +1252,7 @@ enableBucketVersioning ss info _ _ _ = do Init -> when (versioning info) $ enableversioning (bucket info) Enable oldc -> do - oldpc <- either (const mempty) id - . parseRemoteConfig oldc - <$> configParser remote oldc + oldpc <- parsedRemoteConfig remote oldc oldinfo <- extractS3Info oldpc when (versioning info /= versioning oldinfo) $ giveup "Cannot change versioning= of existing S3 remote." diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 29d57d0461..6521cd7af0 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -74,8 +74,9 @@ scsField = Accepted "shared-convergence-secret" furlField :: RemoteConfigField furlField = Accepted "introducer-furl" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost hdl <- liftIO $ TahoeHandle <$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc) diff --git a/Remote/Web.hs b/Remote/Web.hs index a2c0cb6407..603306bf3b 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -21,6 +21,7 @@ import Annex.UUID import Utility.Metered import qualified Annex.Url as Url import Annex.YoutubeDl +import Annex.SpecialRemote.Config remote :: RemoteType remote = RemoteType @@ -41,8 +42,9 @@ list _autoinit = do r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown) return [r] -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r _ c gc rs = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r _ rc gc rs = do + c <- parsedRemoteConfig remote rc cst <- remoteCost gc expensiveRemoteCost return $ Just Remote { uuid = webUUID diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 6879d96e03..5cfb3558fb 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -63,10 +63,12 @@ urlField = Accepted "url" davcredsField :: RemoteConfigField davcredsField = Accepted "davcreds" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) -gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = new + <$> parsedRemoteConfig remote rc + <*> remoteCost gc expensiveRemoteCost where - new cst = Just $ specialRemote c + new c cst = Just $ specialRemote c (prepareDAV this $ store chunkconfig) (prepareDAV this $ retrieve chunkconfig) (prepareDAV this $ remove) @@ -108,7 +110,7 @@ gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost , appendonly = False , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u (M.insert urlField (RemoteConfigValue "http://!dne!/") c) gc rs + , mkUnavailable = gen r u (M.insert urlField (Proposed "http://!dne!/") rc) gc rs , getInfo = includeCredsInfo c (davCreds u) $ [("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)] , claimUrl = Nothing diff --git a/Test.hs b/Test.hs index d193e8c8cc..b0bfe92711 100644 --- a/Test.hs +++ b/Test.hs @@ -1622,7 +1622,7 @@ test_crypto = do checkKeys cip (Just v) <&&> checkCipher encipher ks' _ -> return False where - pc =either mempty id $ + pc = either (const (Types.Remote.ParsedRemoteConfig mempty mempty)) id $ Remote.Helper.Encryptable.parseEncryptionConfig c keysMatch (Utility.Gpg.KeyIds ks') = maybe False (\(Utility.Gpg.KeyIds ks2) -> @@ -1632,7 +1632,7 @@ test_crypto = do checkScheme Types.Crypto.PubKey = scheme == "pubkey" checkKeys cip mvariant = do dummycfg <- Types.GitConfig.dummyRemoteGitConfig - let encparams = (mempty :: Types.Remote.ParsedRemoteConfig, dummycfg) + let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg) cipher <- Crypto.decryptCipher gpgcmd encparams cip files <- filterM doesFileExist $ map ("dir" ) $ concatMap (serializeKeys cipher) keys diff --git a/Types/Remote.hs b/Types/Remote.hs index 12a37a618c..2a0a4deef6 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -58,7 +58,7 @@ data RemoteTypeA a = RemoteType -- The Bool is True if automatic initialization of remotes is desired , enumerate :: Bool -> a [Git.Repo] -- generates a remote of this type - , generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a)) + , generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a)) -- parse configs of remotes of this type , configParser :: RemoteConfig -> a RemoteConfigParser -- initializes or enables a remote diff --git a/Types/RemoteConfig.hs b/Types/RemoteConfig.hs index f0df89a10c..073181e27d 100644 --- a/Types/RemoteConfig.hs +++ b/Types/RemoteConfig.hs @@ -22,7 +22,9 @@ type RemoteConfigField = ProposedAccepted String type RemoteConfig = M.Map RemoteConfigField (ProposedAccepted String) {- Before being used a RemoteConfig has to be parsed. -} -type ParsedRemoteConfig = M.Map RemoteConfigField RemoteConfigValue +data ParsedRemoteConfig = ParsedRemoteConfig + (M.Map RemoteConfigField RemoteConfigValue) + RemoteConfig {- Remotes can have configuration values of many types, so use Typeable - to let them all be stored in here. -} From e535da621cebe874418fb1bfa8922dd5ff0cffa1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 26 Feb 2020 14:57:29 -0400 Subject: [PATCH 2/3] Bugfix to getting content from an export remote with -J, when the export database was not yet populated. (cherry picked from commit e520341500dce9f708a4de674f19047c5d325744) --- CHANGELOG | 2 ++ Remote/Helper/ExportImport.hs | 33 +++++++++---------- ...t_where_versioning_info_was_forgotten.mdwn | 2 ++ ..._4a4d5b62af4a42ab9072ccaa6d8bed7d._comment | 18 ++++++++++ 4 files changed, 37 insertions(+), 18 deletions(-) create mode 100644 doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten/comment_4_4a4d5b62af4a42ab9072ccaa6d8bed7d._comment diff --git a/CHANGELOG b/CHANGELOG index 865043651b..c5a250abb9 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -7,6 +7,8 @@ git-annex (7.20200226) upstream; urgency=high any content that git-annex has stored on them that is not encrypted! * info: Fix display of the encryption value. (Some debugging junk had crept in.) + * Bugfix to getting content from an export remote with -J, when the + export database was not yet populated. -- Joey Hess Wed, 26 Feb 2020 17:18:16 -0400 diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 78b0c05cba..c5b7fbf984 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -148,7 +148,6 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o { storeExport = \f k loc p -> do db <- getciddb ciddbv exportdb <- getexportdb exportdbv - updateexportdb exportdb exportdbv oldks <- liftIO $ Export.getExportTreeKey exportdb loc oldcids <- liftIO $ concat <$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks @@ -265,8 +264,7 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o lcklckv <- liftIO newEmptyTMVarIO dbv <- liftIO newEmptyTMVarIO exportinconflict <- liftIO $ newTVarIO False - exportupdated <- liftIO $ newTMVarIO () - return (dbv, lcklckv, exportinconflict, exportupdated) + return (dbv, lcklckv, exportinconflict) -- Only open the database once it's needed. getciddb (dbtv, lcklckv) = @@ -288,13 +286,18 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o ) -- Only open the database once it's needed. - getexportdb (dbv, lcklckv, _, _) = + -- + -- After opening the database, check if the export log is + -- different than the database, and update the database, to notice + -- when an export has been updated from another repository. + getexportdb (dbv, lcklckv, exportinconflict) = liftIO (atomically (tryReadTMVar dbv)) >>= \case Just db -> return db -- let only one thread take the lock Nothing -> ifM (liftIO $ atomically $ tryPutTMVar lcklckv ()) ( do db <- Export.openDb (uuid r) + updateexportdb db exportinconflict liftIO $ atomically $ putTMVar dbv db return db -- loser waits for winner to open the db and @@ -302,24 +305,18 @@ adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) o , liftIO $ atomically (readTMVar dbv) ) - getexportinconflict (_, _, v, _) = v + getexportinconflict (_, _, v) = v - -- Check once if the export log is different than the database and - -- updates the database, to notice when an export has been - -- updated from another repository. - updateexportdb db (_, _, exportinconflict, exportupdated) = - liftIO (atomically (tryTakeTMVar exportupdated)) >>= \case - Just () -> Export.updateExportTreeFromLog db >>= \case - Export.ExportUpdateSuccess -> return () - Export.ExportUpdateConflict -> do - warnExportImportConflict r - liftIO $ atomically $ - writeTVar exportinconflict True - Nothing -> return () + updateexportdb db exportinconflict = + Export.updateExportTreeFromLog db >>= \case + Export.ExportUpdateSuccess -> return () + Export.ExportUpdateConflict -> do + warnExportImportConflict r + liftIO $ atomically $ + writeTVar exportinconflict True getexportlocs dbv k = do db <- getexportdb dbv - updateexportdb db dbv liftIO $ Export.getExportTree db k retrieveKeyFileFromExport dbv k _af dest p = unVerified $ diff --git a/doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten.mdwn b/doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten.mdwn index 4387afa3b2..5b3d7c31b8 100644 --- a/doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten.mdwn +++ b/doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten.mdwn @@ -89,3 +89,5 @@ get sub-01/meg/sub-01_task-audiovisual_run-01_meg.fif (from s3-PUBLIC...) [[!meta author=yoh]] [[!tag projects/repronim]] + +> [[fixed|done]] --[[Joey]] diff --git a/doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten/comment_4_4a4d5b62af4a42ab9072ccaa6d8bed7d._comment b/doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten/comment_4_4a4d5b62af4a42ab9072ccaa6d8bed7d._comment new file mode 100644 index 0000000000..a1e27d03d6 --- /dev/null +++ b/doc/bugs/fails_to___96__get__96___in_parallel_for_a_freshly_clone_from_public_s3_bucket_where_versioning_info_was_forgotten/comment_4_4a4d5b62af4a42ab9072ccaa6d8bed7d._comment @@ -0,0 +1,18 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 4""" + date="2020-02-26T18:22:46Z" + content=""" +How do I produce such a repo, I thought that git-annex has fixed the +problem that made it not include the S3 versioning information? +I don't want to see a lot of repos being created with that information +missing. + +---- + +Anyway, the S3 version is is a red herring, the failure is actually +caused by the export db not getting populated from the git-annex branch +before some threads try to use it. Remote.Helper.ExportImport has a +updateexportdb that lets one thread update the db, but other threads +don't block waiting for it. Easily fixed. +"""]] From d37975357d600b12fed0c481d43f2419d46fab21 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Feb 2020 13:34:24 -0400 Subject: [PATCH 3/3] Bugfix: export --tracking (a deprecated option) set annex-annex-tracking-branch, instead of annex-tracking-branch. (cherry picked from commit a3a674d15be01a2ee9d27339e9eeb88b21f559dc) --- CHANGELOG | 2 ++ Command/Export.hs | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index c5a250abb9..40e23191de 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -9,6 +9,8 @@ git-annex (7.20200226) upstream; urgency=high (Some debugging junk had crept in.) * Bugfix to getting content from an export remote with -J, when the export database was not yet populated. + * Bugfix: export --tracking (a deprecated option) set + annex-annex-tracking-branch, instead of annex-tracking-branch. -- Joey Hess Wed, 26 Feb 2020 17:18:16 -0400 diff --git a/Command/Export.hs b/Command/Export.hs index f7e66d9c69..aceb2fe545 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -81,7 +81,7 @@ seek o = do -- handle deprecated option when (exportTracking o) $ - setConfig (remoteConfig r "annex-tracking-branch") + setConfig (remoteConfig r "tracking-branch") (fromRef $ exportTreeish o) tree <- filterPreferredContent r =<<