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. -}