diff --git a/Annex/Branch.hs b/Annex/Branch.hs index a8443b7767..b033c059cf 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -63,6 +63,7 @@ import Logs import Logs.Transitions import Logs.File import Logs.Trust.Pure +import Logs.Remote.Pure import Logs.Difference.Pure import qualified Annex.Queue import Annex.Branch.Transitions @@ -574,27 +575,30 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do run [] = noop run changers = do trustmap <- calcTrustMap <$> getStaged trustLog + remoteconfigmap <- calcRemoteConfigMap <$> getStaged remoteLog + -- partially apply, improves performance + let changers' = map (\c -> c trustmap remoteconfigmap) changers fs <- branchFiles forM_ fs $ \f -> do content <- getStaged f - apply changers f content trustmap - apply [] _ _ _ = return () - apply (changer:rest) file content trustmap = - case changer file content trustmap of - RemoveFile -> do - Annex.Queue.addUpdateIndex - =<< inRepo (Git.UpdateIndex.unstageFile file) - -- File is deleted; can't run any other - -- transitions on it. - return () - ChangeFile builder -> do - let content' = toLazyByteString builder - sha <- hashBlob content' - Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ - Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) - apply rest file content' trustmap - PreserveFile -> - apply rest file content trustmap + apply changers' f content + apply [] _ _ = return () + apply (changer:rest) file content = case changer file content of + PreserveFile -> apply rest file content + ChangeFile builder -> do + let content' = toLazyByteString builder + if L.null content' + then do + Annex.Queue.addUpdateIndex + =<< inRepo (Git.UpdateIndex.unstageFile file) + -- File is deleted; can't run any other + -- transitions on it. + return () + else do + sha <- hashBlob content' + Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ + Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) + apply rest file content' checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences ref = do @@ -662,3 +666,4 @@ rememberTreeish treeish graftpoint = lockJournal $ \jl -> do -- and the index was updated to that above, so it's safe to -- say that the index contains c'. setIndexSha c' + diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs index d86dd1a14b..5e57f999d5 100644 --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -20,54 +20,71 @@ import qualified Logs.MetaData.Pure as MetaData import Types.TrustLevel import Types.UUID import Types.MetaData +import Types.Remote +import Annex.SpecialRemote.Config import qualified Data.Map as M -import qualified Data.Set as S import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import Data.ByteString.Builder data FileTransition = ChangeFile Builder - | RemoveFile | PreserveFile -type TransitionCalculator = FilePath -> L.ByteString -> TrustMap -> FileTransition +type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> FilePath -> L.ByteString -> FileTransition getTransitionCalculator :: Transition -> Maybe TransitionCalculator getTransitionCalculator ForgetGitHistory = Nothing getTransitionCalculator ForgetDeadRemotes = Just dropDead -dropDead :: FilePath -> L.ByteString -> TrustMap -> FileTransition -dropDead f content trustmap = case getLogVariety f of +-- Removes data about all dead repos. +-- +-- The trust log is not changed, because other, unmerged clones +-- may contain other data about the dead repos. So we need to rememebr +-- which are dead to later remove that. +-- +-- When the remote log contains a sameas-uuid pointing to a dead uuid, +-- the uuid of that remote configuration is also effectively dead, +-- though not in the trust log. There may be per-remote state stored using +-- the latter uuid, that also needs to be removed. That configuration +-- is not removed from the remote log, for the same reason the trust log +-- is not changed. +dropDead :: TransitionCalculator +dropDead trustmap remoteconfigmap f content = case getLogVariety f of Just OldUUIDBasedLog - -- Don't remove the dead repo from the trust log, - -- because git remotes may still exist, and they need - -- to still know it's dead. | f == trustLog -> PreserveFile - | otherwise -> ChangeFile $ - UUIDBased.buildLogOld byteString $ - dropDeadFromMapLog trustmap id $ - UUIDBased.parseLogOld A.takeByteString content + | otherwise -> + let go tm = ChangeFile $ + UUIDBased.buildLogOld byteString $ + dropDeadFromMapLog tm id $ + UUIDBased.parseLogOld A.takeByteString content + in if f == remoteLog + then go trustmap + else go trustmap' Just NewUUIDBasedLog -> ChangeFile $ UUIDBased.buildLogNew byteString $ - dropDeadFromMapLog trustmap id $ + dropDeadFromMapLog trustmap' id $ UUIDBased.parseLogNew A.takeByteString content Just (ChunkLog _) -> ChangeFile $ - Chunk.buildLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content - Just (PresenceLog _) -> - let newlog = Presence.compactLog $ - dropDeadFromPresenceLog trustmap $ Presence.parseLog content - in if null newlog - then RemoveFile - else ChangeFile $ Presence.buildLog newlog - Just RemoteMetaDataLog -> - let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content - in if S.null newlog - then RemoveFile - else ChangeFile $ MetaData.buildLog newlog + Chunk.buildLog $ dropDeadFromMapLog trustmap' fst $ + Chunk.parseLog content + Just (PresenceLog _) -> ChangeFile $ Presence.buildLog $ + Presence.compactLog $ + dropDeadFromPresenceLog trustmap' $ + Presence.parseLog content + Just RemoteMetaDataLog -> ChangeFile $ MetaData.buildLog $ + dropDeadFromRemoteMetaDataLog trustmap' $ + MetaData.simplifyLog $ MetaData.parseLog content Just OtherLog -> PreserveFile Nothing -> PreserveFile + where + trustmap' = trustmap `M.union` + M.map (const DeadTrusted) (M.filter sameasdead remoteconfigmap) + sameasdead cm = + case toUUID <$> M.lookup sameasUUIDField cm of + Nothing -> False + Just u' -> M.lookup u' trustmap == Just DeadTrusted dropDeadFromMapLog :: TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v dropDeadFromMapLog trustmap getuuid = diff --git a/Annex/Import.hs b/Annex/Import.hs index 4a9ea8e68e..9a939937af 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -382,7 +382,7 @@ downloadImport remote importtreeconfig importablecontents = do getTopFilePath subdir fromImportLocation loc getcidkey cidmap db cid = liftIO $ - CIDDb.getContentIdentifierKeys db (Remote.uuid remote) cid >>= \case + CIDDb.getContentIdentifierKeys db rs cid >>= \case [] -> atomically $ maybeToList . M.lookup cid <$> readTVar cidmap l -> return l @@ -390,8 +390,10 @@ downloadImport remote importtreeconfig importablecontents = do recordcidkey cidmap db cid k = do liftIO $ atomically $ modifyTVar' cidmap $ M.insert cid k - liftIO $ CIDDb.recordContentIdentifier db (Remote.uuid remote) cid k - CIDLog.recordContentIdentifier (Remote.uuid remote) cid k + liftIO $ CIDDb.recordContentIdentifier db rs cid k + CIDLog.recordContentIdentifier rs cid k + + rs = Remote.remoteStateHandle remote {- Temporary key used for import of a ContentIdentifier while downloading - content, before generating its real key. -} diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs index ca8078c90f..828eb6e775 100644 --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -1,19 +1,26 @@ {- git-annex special remote configuration - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.SpecialRemote where +module Annex.SpecialRemote ( + module Annex.SpecialRemote, + module Annex.SpecialRemote.Config +) where import Annex.Common -import Remote (remoteTypes, remoteMap) -import Types.Remote (RemoteConfig, RemoteConfigKey, SetupStage(..), typename, setup) +import Annex.SpecialRemote.Config +import Remote (remoteTypes) +import Types.Remote (RemoteConfig, SetupStage(..), typename, setup) import Types.GitConfig +import Config +import Remote.List import Logs.Remote import Logs.Trust import qualified Git.Config +import qualified Types.Remote as Remote import Git.Types (RemoteName) import qualified Data.Map as M @@ -22,38 +29,54 @@ import Data.Ord {- See if there's an existing special remote with this name. - - Prefer remotes that are not dead when a name appears multiple times. -} -findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig)) +findExisting :: RemoteName -> Annex (Maybe (UUID, RemoteConfig, Maybe (ConfigFrom UUID))) findExisting name = do t <- trustMap headMaybe - . sortBy (comparing $ \(u, _c) -> Down $ M.lookup u t) + . sortBy (comparing $ \(u, _, _) -> Down $ M.lookup u t) . findByName name <$> Logs.Remote.readRemoteLog -newConfig :: RemoteName -> RemoteConfig -newConfig = M.singleton nameKey - -findByName :: RemoteName -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig)] -findByName n = filter (matching . snd) . M.toList +findByName :: RemoteName -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig, Maybe (ConfigFrom UUID))] +findByName n = map sameasuuid . filter (matching . snd) . M.toList where - matching c = case M.lookup nameKey c of + matching c = case lookupName c of Nothing -> False Just n' | n' == n -> True | otherwise -> False + sameasuuid (u, c) = case M.lookup sameasUUIDField c of + Nothing -> (u, c, Nothing) + Just u' -> (toUUID u', c, Just (ConfigFrom u)) + +newConfig + :: RemoteName + -> Maybe (Sameas UUID) + -> RemoteConfig + -- ^ configuration provided by the user + -> M.Map UUID RemoteConfig + -- ^ configuration of other special remotes, to inherit from + -- when sameas is used + -> RemoteConfig +newConfig name sameas fromuser m = case sameas of + Nothing -> M.insert nameField name fromuser + Just (Sameas u) -> addSameasInherited m $ M.fromList + [ (sameasNameField, name) + , (sameasUUIDField, fromUUID u) + ] `M.union` fromuser specialRemoteMap :: Annex (M.Map UUID RemoteName) specialRemoteMap = do m <- Logs.Remote.readRemoteLog return $ M.fromList $ mapMaybe go (M.toList m) where - go (u, c) = case M.lookup nameKey c of + go (u, c) = case lookupName c of Nothing -> Nothing Just n -> Just (u, n) -{- find the specified remote type -} +{- find the remote type -} findType :: RemoteConfig -> Either String RemoteType -findType config = maybe unspecified specified $ M.lookup typeKey config +findType config = maybe unspecified specified $ M.lookup typeField config where unspecified = Left "Specify the type of remote with type=" specified s = case filter (findtype s) remoteTypes of @@ -61,31 +84,31 @@ findType config = maybe unspecified specified $ M.lookup typeKey config (t:_) -> Right t findtype s i = typename i == s -{- The name of a configured remote is stored in its config using this key. -} -nameKey :: RemoteConfigKey -nameKey = "name" - -{- The type of a remote is stored in its config using this key. -} -typeKey :: RemoteConfigKey -typeKey = "type" - -autoEnableKey :: RemoteConfigKey -autoEnableKey = "autoenable" - autoEnable :: Annex () autoEnable = do remotemap <- M.filter configured <$> readRemoteLog - enabled <- remoteMap id - forM_ (M.toList remotemap) $ \(u, c) -> unless (u `M.member` enabled) $ do - case (M.lookup nameKey c, findType c) of + enabled <- getenabledremotes + forM_ (M.toList remotemap) $ \(cu, c) -> unless (cu `M.member` enabled) $ do + let u = case findSameasUUID c of + Just (Sameas u') -> u' + Nothing -> cu + case (lookupName c, findType c) of (Just name, Right t) -> whenM (canenable u) $ do showSideAction $ "Auto enabling special remote " ++ name dummycfg <- liftIO dummyRemoteGitConfig tryNonAsync (setup t (Enable c) (Just u) Nothing c dummycfg) >>= \case Left e -> warning (show e) - Right _ -> return () + Right (_c, _u) -> + when (cu /= u) $ + setConfig (remoteConfig c "config-uuid") (fromUUID cu) _ -> return () where configured rc = fromMaybe False $ - Git.Config.isTrue =<< M.lookup autoEnableKey rc + Git.Config.isTrue =<< M.lookup autoEnableField rc canenable u = (/= DeadTrusted) <$> lookupTrust u + getenabledremotes = M.fromList + . map (\r -> (getcu r, r)) + <$> remoteList + getcu r = fromMaybe + (Remote.uuid r) + (remoteAnnexConfigUUID (Remote.gitconfig r)) diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs new file mode 100644 index 0000000000..73688569c6 --- /dev/null +++ b/Annex/SpecialRemote/Config.hs @@ -0,0 +1,103 @@ +{- git-annex special remote configuration + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.SpecialRemote.Config where + +import Common +import Types.Remote (RemoteConfigField, RemoteConfig) +import Types.UUID + +import qualified Data.Map as M +import qualified Data.Set as S + +newtype Sameas t = Sameas t + deriving (Show) + +newtype ConfigFrom t = ConfigFrom t + deriving (Show) + +{- The name of a configured remote is stored in its config using this key. -} +nameField :: RemoteConfigField +nameField = "name" + +{- The name of a sameas remote is stored using this key instead. + - This prevents old versions of git-annex getting confused. -} +sameasNameField :: RemoteConfigField +sameasNameField = "sameas-name" + +lookupName :: RemoteConfig -> Maybe String +lookupName c = M.lookup nameField c <|> M.lookup sameasNameField c + +{- The uuid that a sameas remote is the same as is stored in this key. -} +sameasUUIDField :: RemoteConfigField +sameasUUIDField = "sameas-uuid" + +{- The type of a remote is stored in its config using this key. -} +typeField :: RemoteConfigField +typeField = "type" + +autoEnableField :: RemoteConfigField +autoEnableField = "autoenable" + +encryptionField :: RemoteConfigField +encryptionField = "encryption" + +macField :: RemoteConfigField +macField = "mac" + +cipherField :: RemoteConfigField +cipherField = "cipher" + +cipherkeysField :: RemoteConfigField +cipherkeysField = "cipherkeys" + +pubkeysField :: RemoteConfigField +pubkeysField = "pubkeys" + +chunksizeField :: RemoteConfigField +chunksizeField = "chunksize" + +{- A remote with sameas-uuid set will inherit these values from the config + - of that uuid. These values cannot be overridden in the remote's config. -} +sameasInherits :: S.Set RemoteConfigField +sameasInherits = S.fromList + -- encryption configuration is necessarily the same for two + -- remotes that access the same data store + [ encryptionField + , macField + , cipherField + , cipherkeysField + , pubkeysField + -- legacy chunking was either enabled or not, so has to be the same + -- across configs for remotes that access the same data + -- (new-style chunking does not have that limitation) + , chunksizeField + ] + +{- Each RemoteConfig that has a sameas-uuid inherits some fields + - from it. Such fields can only be set by inheritance; the RemoteConfig + - cannot provide values from them. -} +addSameasInherited :: M.Map UUID RemoteConfig -> RemoteConfig -> RemoteConfig +addSameasInherited m c = case findSameasUUID c of + Nothing -> c + Just (Sameas sameasuuid) -> case M.lookup sameasuuid m of + Nothing -> c + Just parentc -> + M.withoutKeys c sameasInherits + `M.union` + M.restrictKeys parentc sameasInherits + +findSameasUUID :: RemoteConfig -> Maybe (Sameas UUID) +findSameasUUID c = Sameas . toUUID <$> M.lookup sameasUUIDField c + +{- Remove any fields inherited from a sameas-uuid. When storing a + - RemoteConfig, those fields don't get stored, since they were already + - inherited. -} +removeSameasInherited :: RemoteConfig -> RemoteConfig +removeSameasInherited c = case M.lookup sameasUUIDField c of + Nothing -> c + Just _ -> M.withoutKeys c sameasInherits diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs index 8910e83854..6215fba389 100644 --- a/Assistant/Gpg.hs +++ b/Assistant/Gpg.hs @@ -9,7 +9,8 @@ module Assistant.Gpg where import Utility.Gpg import Utility.UserInfo -import Types.Remote (RemoteConfigKey) +import Types.Remote (RemoteConfigField) +import Annex.SpecialRemote.Config import qualified Data.Map as M import Control.Applicative @@ -30,7 +31,7 @@ data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption deriving (Eq) {- Generates Remote configuration for encryption. -} -configureEncryption :: EnableEncryption -> (RemoteConfigKey, String) -configureEncryption SharedEncryption = ("encryption", "shared") -configureEncryption NoEncryption = ("encryption", "none") -configureEncryption HybridEncryption = ("encryption", "hybrid") +configureEncryption :: EnableEncryption -> (RemoteConfigField, String) +configureEncryption SharedEncryption = (encryptionField, "shared") +configureEncryption NoEncryption = (encryptionField, "none") +configureEncryption HybridEncryption = (encryptionField, "hybrid") diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 83eb40c321..99d68ab82d 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -18,6 +18,7 @@ import qualified Git import qualified Git.Command import qualified Annex import qualified Annex.SpecialRemote +import Annex.SpecialRemote.Config import Logs.UUID import Logs.Remote import Git.Remote @@ -26,6 +27,7 @@ import Creds import Assistant.Gpg import Utility.Gpg (KeyId) import Types.GitConfig +import Config import qualified Data.Map as M @@ -51,11 +53,11 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $ go =<< Annex.SpecialRemote.findExisting name where go Nothing = setupSpecialRemote name Rsync.remote config Nothing - (Nothing, R.Init, Annex.SpecialRemote.newConfig name) - go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing - (Just u, R.Enable c, c) + (Nothing, R.Init, Annex.SpecialRemote.newConfig name Nothing mempty mempty) Nothing + go (Just (u, c, mcu)) = setupSpecialRemote name Rsync.remote config Nothing + (Just u, R.Enable c, c) mcu config = M.fromList - [ ("encryption", "shared") + [ (encryptionField, "shared") , ("rsyncurl", location) , ("type", "rsync") ] @@ -82,7 +84,7 @@ initSpecialRemote name remotetype mcreds config = go 0 let fullname = if n == 0 then name else name ++ show n Annex.SpecialRemote.findExisting fullname >>= \case Nothing -> setupSpecialRemote fullname remotetype config mcreds - (Nothing, R.Init, Annex.SpecialRemote.newConfig fullname) + (Nothing, R.Init, Annex.SpecialRemote.newConfig fullname Nothing mempty mempty) Nothing Just _ -> go (n + 1) {- Enables an existing special remote. -} @@ -90,13 +92,13 @@ enableSpecialRemote :: SpecialRemoteMaker enableSpecialRemote name remotetype mcreds config = Annex.SpecialRemote.findExisting name >>= \case Nothing -> error $ "Cannot find a special remote named " ++ name - Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) + Just (u, c, mcu) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) mcu -setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName +setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName setupSpecialRemote = setupSpecialRemote' True -setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName -setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) = do +setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName +setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) mcu = do {- Currently, only 'weak' ciphers can be generated from the - assistant, because otherwise GnuPG may block once the entropy - pool is drained, and as of now there's no way to tell the user @@ -104,7 +106,12 @@ setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) = do let weakc = M.insert "highRandomQuality" "false" $ M.union config c dummycfg <- liftIO dummyRemoteGitConfig (c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg - configSet u c' + case mcu of + Nothing -> + configSet u c' + Just (Annex.SpecialRemote.ConfigFrom cu) -> do + setConfig (remoteConfig c' "config-uuid") (fromUUID cu) + configSet cu c' when setdesc $ whenM (isNothing . M.lookup u <$> uuidDescMap) $ describeUUID u (toUUIDDesc name) diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index e4d2826adf..c924a78800 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -24,6 +24,7 @@ import Types.StandardGroups import Creds import Assistant.Gpg import Git.Types (RemoteName) +import Annex.SpecialRemote.Config import qualified Data.Text as T import qualified Data.Map as M @@ -195,7 +196,7 @@ enableAWSRemote remotetype uuid = do case result of FormSuccess creds -> liftH $ do m <- liftAnnex readRemoteLog - let name = fromJust $ M.lookup "name" $ + let name = fromJust $ lookupName $ fromJust $ M.lookup uuid m makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty _ -> do diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index 32164339f5..84d609761e 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -24,6 +24,7 @@ import Assistant.Gpg import Types.Remote (RemoteConfig) import qualified Annex.Url as Url import Creds +import Annex.SpecialRemote.Config import qualified Data.Text as T import qualified Data.Map as M @@ -169,7 +170,7 @@ enableIARemote uuid = do case result of FormSuccess creds -> liftH $ do m <- liftAnnex readRemoteLog - let name = fromJust $ M.lookup "name" $ + let name = fromJust $ lookupName $ fromJust $ M.lookup uuid m AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty _ -> do diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index a86451edd8..b140e99dcc 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -27,6 +27,7 @@ import qualified Git.Command import qualified Annex.Branch import Annex.UUID import Logs.UUID +import Annex.SpecialRemote.Config import Assistant.RemoteControl import Types.Creds import Assistant.CredPairCache @@ -208,7 +209,7 @@ postEnableSshGitRemoteR = enableSshRemote getsshinput enableRsyncNet enablesshgi enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html enableSshRemote getsshdata rsyncnetsetup genericsetup u = do m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog - case (unmangle <$> getsshdata m, M.lookup "name" m) of + case (unmangle <$> getsshdata m, lookupName m) of (Just sshdata, Just reponame) -> sshConfigurator $ do ((result, form), enctype) <- liftH $ runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ @@ -546,7 +547,9 @@ makeSshRepo rs sshdata let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m) let c' = M.insert "location" (genSshUrl sshdata) $ M.insert "type" "git" $ - M.insert "name" (fromMaybe (Remote.name r) (M.lookup "name" c)) c + case M.lookup nameField c of + Just _ -> c + Nothing -> M.insert nameField (Remote.name r) c configSet (Remote.uuid r) c' makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index e393d02b97..cec43e1a5f 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -21,6 +21,7 @@ import Logs.Remote import Git.Types (RemoteName) import Assistant.Gpg import Types.GitConfig +import Annex.SpecialRemote.Config import qualified Data.Map as M #endif @@ -56,7 +57,7 @@ postEnableWebDAVR :: UUID -> Handler Html postEnableWebDAVR uuid = do m <- liftAnnex readRemoteLog let c = fromJust $ M.lookup uuid m - let name = fromJust $ M.lookup "name" c + let name = fromJust $ lookupName c let url = fromJust $ M.lookup "url" c mcreds <- liftAnnex $ do dummycfg <- liftIO dummyRemoteGitConfig diff --git a/Assistant/WebApp/Gpg.hs b/Assistant/WebApp/Gpg.hs index 22285cf451..d8be86b2b0 100644 --- a/Assistant/WebApp/Gpg.hs +++ b/Assistant/WebApp/Gpg.hs @@ -21,6 +21,7 @@ import qualified Git.GCrypt import qualified Remote.GCrypt as GCrypt import Git.Types (RemoteName) import Assistant.WebApp.MakeRemote +import Annex.SpecialRemote.Config import Logs.Remote import qualified Data.Map as M @@ -79,7 +80,7 @@ getGCryptRemoteName u repoloc = do mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote]) ( do void Annex.Branch.forceUpdate - (M.lookup "name" <=< M.lookup u) <$> readRemoteLog + (lookupName <=< M.lookup u) <$> readRemoteLog , return Nothing ) void $ inRepo $ Git.Remote.Remove.remove tmpremote diff --git a/CHANGELOG b/CHANGELOG index 21a27df882..81d32398cd 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,17 @@ +git-annex (7.20191011) UNRELEASED; urgency=medium + + * initremote: Added --sameas option, allows for two special remotes that + access the same data store. + * Note that due to complications of the sameas feature, any external + special remotes that try to send SETSTATE or GETSTATE during INITREMOTE + or EXPORTSUPPORTED will now get back an ERROR. That would be a very + hackish thing for an external special remote to do, needing some kind + of hard-coded key value to be used, so probably nothing will be affected. + * forget --drop-dead: Remove several classes of git-annex log files + when they become empty, further reducing the size of the git-annex branch. + + -- Joey Hess Thu, 19 Sep 2019 11:11:19 -0400 + git-annex (7.20191009) upstream; urgency=medium * Fix bug in handling of annex.largefiles that use largerthan/smallerthan. diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index ae66588d00..117a876edb 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -1,6 +1,6 @@ {- git-annex command-line option parsing - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -114,6 +114,10 @@ parseRemoteOption = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just +parseUUIDOption :: String -> DeferredParse UUID +parseUUIDOption = DeferredParse + . (Remote.nameToUUID) + -- | From or To a remote. data FromToOptions = FromRemote (DeferredParse Remote) diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index 1af7cd073b..8cf86ea5ed 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2013-2016 Joey Hess + - Copyright 2013-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,7 +13,7 @@ import qualified Logs.Remote import qualified Types.Remote as R import qualified Git import qualified Git.Types as Git -import qualified Annex.SpecialRemote +import qualified Annex.SpecialRemote as SpecialRemote import qualified Remote import qualified Types.Remote as Remote import qualified Remote.Git @@ -40,7 +40,7 @@ start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes where matchingname r = Git.remoteName r == Just name go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest) - =<< Annex.SpecialRemote.findExisting name + =<< SpecialRemote.findExisting name go (r:_) = do -- This could be either a normal git remote or a special -- remote that has an url (eg gcrypt). @@ -62,32 +62,37 @@ startNormalRemote name restparams r | otherwise = giveup $ "That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams -startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig) -> CommandStart +startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID)) -> CommandStart startSpecialRemote name config Nothing = do - m <- Annex.SpecialRemote.specialRemoteMap + m <- SpecialRemote.specialRemoteMap confm <- Logs.Remote.readRemoteLog Remote.nameToUUID' name >>= \case Right u | u `M.member` m -> startSpecialRemote name config $ - Just (u, fromMaybe M.empty (M.lookup u confm)) + Just (u, fromMaybe M.empty (M.lookup u confm), Nothing) _ -> unknownNameError "Unknown remote name." -startSpecialRemote name config (Just (u, c)) = +startSpecialRemote name config (Just (u, c, mcu)) = starting "enableremote" (ActionItemOther (Just name)) $ do let fullconfig = config `M.union` c - t <- either giveup return (Annex.SpecialRemote.findType fullconfig) + t <- either giveup return (SpecialRemote.findType fullconfig) gc <- maybe (liftIO dummyRemoteGitConfig) (return . Remote.gitconfig) =<< Remote.byUUID u - performSpecialRemote t u c fullconfig gc + performSpecialRemote t u c fullconfig gc mcu -performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform -performSpecialRemote t u oldc c gc = do +performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform +performSpecialRemote t u oldc c gc mcu = do (c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc - next $ cleanupSpecialRemote u' c' + next $ cleanupSpecialRemote u' c' mcu -cleanupSpecialRemote :: UUID -> R.RemoteConfig -> CommandCleanup -cleanupSpecialRemote u c = do - Logs.Remote.configSet u c +cleanupSpecialRemote :: UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup +cleanupSpecialRemote u c mcu = do + case mcu of + Nothing -> + Logs.Remote.configSet u c + Just (SpecialRemote.ConfigFrom cu) -> do + setConfig (remoteConfig c "config-uuid") (fromUUID cu) + Logs.Remote.configSet cu c Remote.byUUID u >>= \case Nothing -> noop Just r -> do @@ -97,7 +102,7 @@ cleanupSpecialRemote u c = do unknownNameError :: String -> Annex a unknownNameError prefix = do - m <- Annex.SpecialRemote.specialRemoteMap + m <- SpecialRemote.specialRemoteMap descm <- M.unionWith Remote.addName <$> uuidDescMap <*> pure (M.map toUUIDDesc m) diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 186ee1ca5e..00ba46dc90 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011,2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,50 +14,82 @@ import Annex.SpecialRemote import qualified Remote import qualified Logs.Remote import qualified Types.Remote as R +import Annex.UUID import Logs.UUID +import Logs.Remote import Types.GitConfig +import Config cmd :: Command cmd = command "initremote" SectionSetup "creates a special (non-git) remote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) - (withParams seek) + (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek = withWords (commandAction . start) +data InitRemoteOptions = InitRemoteOptions + { cmdparams :: CmdParams + , sameas :: Maybe (DeferredParse UUID) + } -start :: [String] -> CommandStart -start [] = giveup "Specify a name for the remote." -start (name:ws) = ifM (isJust <$> findExisting name) +optParser :: CmdParamsDesc -> Parser InitRemoteOptions +optParser desc = InitRemoteOptions + <$> cmdParams desc + <*> optional parseSameasOption + +parseSameasOption :: Parser (DeferredParse UUID) +parseSameasOption = parseUUIDOption <$> strOption + ( long "sameas" + <> metavar (paramRemote `paramOr` paramDesc `paramOr` paramUUID) + <> help "new remote that accesses the same data" + <> completeRemotes + ) + +seek :: InitRemoteOptions -> CommandSeek +seek o = withWords (commandAction . (start o)) (cmdparams o) + +start :: InitRemoteOptions -> [String] -> CommandStart +start _ [] = giveup "Specify a name for the remote." +start o (name:ws) = ifM (isJust <$> findExisting name) ( giveup $ "There is already a special remote named \"" ++ name ++ "\". (Use enableremote to enable an existing special remote.)" , do ifM (isJust <$> Remote.byNameOnly name) ( giveup $ "There is already a remote named \"" ++ name ++ "\"" , do - let c = newConfig name - t <- either giveup return (findType config) + sameasuuid <- maybe + (pure Nothing) + (Just . Sameas <$$> getParsed) + (sameas o) + c <- newConfig name sameasuuid + (Logs.Remote.keyValToConfig ws) + <$> readRemoteLog + t <- either giveup return (findType c) starting "initremote" (ActionItemOther (Just name)) $ - perform t name $ M.union config c + perform t name c o ) ) - where - config = Logs.Remote.keyValToConfig ws -perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform -perform t name c = do +perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform +perform t name c o = do dummycfg <- liftIO dummyRemoteGitConfig - (c', u) <- R.setup t R.Init cu Nothing c dummycfg - next $ cleanup u name c' + (c', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c dummycfg + next $ cleanup u name c' o where - cu = case M.lookup "uuid" c of + uuidfromuser = case M.lookup "uuid" c of Just s | isUUID s -> Just (toUUID s) | otherwise -> giveup "invalid uuid" Nothing -> Nothing + sameasu = toUUID <$> M.lookup sameasUUIDField c -cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup -cleanup u name c = do - describeUUID u (toUUIDDesc name) - Logs.Remote.configSet u c +cleanup :: UUID -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup +cleanup u name c o = do + case sameas o of + Nothing -> do + describeUUID u (toUUIDDesc name) + Logs.Remote.configSet u c + Just _ -> do + cu <- liftIO genUUID + setConfig (remoteConfig c "config-uuid") (fromUUID cu) + Logs.Remote.configSet cu c return True diff --git a/Command/RenameRemote.hs b/Command/RenameRemote.hs index ac4228eb8d..51e0127b0d 100644 --- a/Command/RenameRemote.hs +++ b/Command/RenameRemote.hs @@ -9,6 +9,7 @@ module Command.RenameRemote where import Command import qualified Annex.SpecialRemote +import Annex.SpecialRemote.Config (nameField, sameasNameField) import qualified Logs.Remote import qualified Types.Remote as R import qualified Remote @@ -26,9 +27,9 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case - Just (u, cfg) -> Annex.SpecialRemote.findExisting newname >>= \case + Just (u, cfg, mcu) -> Annex.SpecialRemote.findExisting newname >>= \case Just _ -> giveup $ "The name " ++ newname ++ " is already used by a special remote." - Nothing -> go u cfg + Nothing -> go u cfg mcu -- Support lookup by uuid or description as well as remote name, -- as a fallback when there is nothing with the name in the -- special remote log. @@ -38,13 +39,17 @@ start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case m <- Logs.Remote.readRemoteLog case M.lookup u m of Nothing -> giveup "That is not a special remote." - Just cfg -> go u cfg + Just cfg -> go u cfg Nothing where - go u cfg = starting "rename" (ActionItemOther Nothing) $ - perform u cfg newname + go u cfg mcu = starting "rename" (ActionItemOther Nothing) $ + perform u cfg mcu newname start _ = giveup "Specify an old name (or uuid or description) and a new name." -perform :: UUID -> R.RemoteConfig -> String -> CommandPerform -perform u cfg newname = do - Logs.Remote.configSet u (M.insert "name" newname cfg) +perform :: UUID -> R.RemoteConfig -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> String -> CommandPerform +perform u cfg mcu newname = do + let (namefield, cu) = case mcu of + Nothing -> (nameField, u) + Just (Annex.SpecialRemote.ConfigFrom u') -> (sameasNameField, u') + Logs.Remote.configSet cu (M.insert namefield newname cfg) + next $ return True diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 5232d91bef..0e7403f19b 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -153,6 +153,7 @@ adjustRemoteConfig r adjustconfig = do (Remote.uuid r) (adjustconfig (Remote.config r)) (Remote.gitconfig r) + (Remote.remoteStateHandle r) test :: Annex.AnnexState -> Remote -> Key -> [TestTree] test st r k = catMaybes diff --git a/Config.hs b/Config.hs index 75b3af100c..cbd82e50f7 100644 --- a/Config.hs +++ b/Config.hs @@ -19,6 +19,7 @@ import Config.DynamicConfig import Types.Availability import Git.Types import qualified Types.Remote as Remote +import qualified Annex.SpecialRemote.Config as SpecialRemote import qualified Data.Map as M @@ -62,7 +63,7 @@ instance RemoteNameable Remote where getRemoteName = Remote.name instance RemoteNameable Remote.RemoteConfig where - getRemoteName c = fromMaybe "" (M.lookup "name" c) + getRemoteName c = fromMaybe "" (SpecialRemote.lookupName c) {- A per-remote config setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey diff --git a/Creds.hs b/Creds.hs index 08f4fc51a8..3531060d09 100644 --- a/Creds.hs +++ b/Creds.hs @@ -26,7 +26,7 @@ import Types.Creds import Annex.Perms import Utility.FileMode import Crypto -import Types.Remote (RemoteConfig, RemoteConfigKey) +import Types.Remote (RemoteConfig, RemoteConfigField) import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher) import Utility.Env (getEnv) @@ -39,7 +39,7 @@ import Utility.Base64 data CredPairStorage = CredPairStorage { credPairFile :: FilePath , credPairEnvironment :: (String, String) - , credPairRemoteKey :: RemoteConfigKey + , credPairRemoteField :: RemoteConfigField } {- Stores creds in a remote's configuration, if the remote allows @@ -58,7 +58,7 @@ setRemoteCredPair encsetup c gc storage mcreds = case mcreds of =<< getRemoteCredPair c gc storage Just creds | embedCreds c -> - let key = credPairRemoteKey storage + let key = credPairRemoteField storage in storeconfig creds key =<< flip remoteCipher gc =<< localcache creds | otherwise -> localcache creds where @@ -84,7 +84,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv fromenv = liftIO $ getEnvCredPair storage fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage fromconfig = do - let key = credPairRemoteKey storage + let key = credPairRemoteField storage mcipher <- remoteCipher' c gc case (M.lookup key c, mcipher) of (Nothing, _) -> return Nothing @@ -190,7 +190,7 @@ includeCredsInfo c storage info = do Just _ -> do let (uenv, penv) = credPairEnvironment storage ret $ "from environment variables (" ++ unwords [uenv, penv] ++ ")" - Nothing -> case (`M.lookup` c) (credPairRemoteKey storage) of + Nothing -> case (`M.lookup` c) (credPairRemoteField storage) of Nothing -> ifM (existsCacheCredPair storage) ( ret "stored locally" , ret "not available" diff --git a/Crypto.hs b/Crypto.hs index f21cb57c94..8dd4e3d4f1 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -45,6 +45,7 @@ import qualified Utility.Gpg as Gpg import Types.Crypto import Types.Remote import Types.Key +import Annex.SpecialRemote.Config {- The beginning of a Cipher is used for MAC'ing; the remainder is used - as the GPG symmetric encryption passphrase when using the hybrid @@ -236,9 +237,9 @@ instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++ {- When the remote is configured to use public-key encryption, - look up the recipient keys and add them to the option list. -} - case M.lookup "encryption" c of - Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup "cipherkeys" c - Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup "pubkeys" c + case M.lookup encryptionField c of + Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup cipherkeysField c + Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup pubkeysField c _ -> [] getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc) diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs index f9cb0d1cd1..024825eaec 100644 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -34,6 +34,7 @@ import Annex.Locations import Annex.Common hiding (delete) import qualified Annex.Branch import Types.Import +import Types.RemoteState import Git.Types import Git.Sha import Git.FilePath @@ -89,20 +90,21 @@ flushDbQueue :: ContentIdentifierHandle -> IO () flushDbQueue (ContentIdentifierHandle h) = H.flushDbQueue h -- Be sure to also update the git-annex branch when using this. -recordContentIdentifier :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> Key -> IO () -recordContentIdentifier h u cid k = queueDb h $ do +recordContentIdentifier :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> Key -> IO () +recordContentIdentifier h (RemoteStateHandle u) cid k = queueDb h $ do void $ insert_ $ ContentIdentifiers u cid (toIKey k) -getContentIdentifiers :: ContentIdentifierHandle -> UUID -> Key -> IO [ContentIdentifier] -getContentIdentifiers (ContentIdentifierHandle h) u k = H.queryDbQueue h $ do - l <- selectList - [ ContentIdentifiersKey ==. toIKey k - , ContentIdentifiersRemote ==. u - ] [] - return $ map (contentIdentifiersCid . entityVal) l +getContentIdentifiers :: ContentIdentifierHandle -> RemoteStateHandle -> Key -> IO [ContentIdentifier] +getContentIdentifiers (ContentIdentifierHandle h) (RemoteStateHandle u) k = + H.queryDbQueue h $ do + l <- selectList + [ ContentIdentifiersKey ==. toIKey k + , ContentIdentifiersRemote ==. u + ] [] + return $ map (contentIdentifiersCid . entityVal) l -getContentIdentifierKeys :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> IO [Key] -getContentIdentifierKeys (ContentIdentifierHandle h) u cid = +getContentIdentifierKeys :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> IO [Key] +getContentIdentifierKeys (ContentIdentifierHandle h) (RemoteStateHandle u) cid = H.queryDbQueue h $ do l <- selectList [ ContentIdentifiersCid ==. cid @@ -147,6 +149,6 @@ updateFromLog db (oldtree, currtree) = do Nothing -> return () Just k -> do l <- Log.getContentIdentifiers k - liftIO $ forM_ l $ \(u, cids) -> + liftIO $ forM_ l $ \(rs, cids) -> forM_ cids $ \cid -> - recordContentIdentifier db u cid k + recordContentIdentifier db rs cid k diff --git a/Logs/ContentIdentifier.hs b/Logs/ContentIdentifier.hs index d3e6a50b9b..38f904ae2b 100644 --- a/Logs/ContentIdentifier.hs +++ b/Logs/ContentIdentifier.hs @@ -15,6 +15,7 @@ import Annex.Common import Logs import Logs.MapLog import Types.Import +import Types.RemoteState import qualified Annex.Branch import Logs.ContentIdentifier.Pure as X import qualified Annex @@ -27,8 +28,8 @@ import qualified Data.List.NonEmpty as NonEmpty -- -- A remote may use multiple content identifiers for the same key over time, -- so ones that were recorded before are preserved. -recordContentIdentifier :: UUID -> ContentIdentifier -> Key -> Annex () -recordContentIdentifier u cid k = do +recordContentIdentifier :: RemoteStateHandle -> ContentIdentifier -> Key -> Annex () +recordContentIdentifier (RemoteStateHandle u) cid k = do c <- liftIO currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (remoteContentIdentifierLogFile config k) $ @@ -39,9 +40,9 @@ recordContentIdentifier u cid k = do m = simpleMap l -- | Get all known content identifiers for a key. -getContentIdentifiers :: Key -> Annex [(UUID, [ContentIdentifier])] +getContentIdentifiers :: Key -> Annex [(RemoteStateHandle, [ContentIdentifier])] getContentIdentifiers k = do config <- Annex.getGitConfig - map (\(u, l) -> (u, NonEmpty.toList l) ) + map (\(u, l) -> (RemoteStateHandle u, NonEmpty.toList l) ) . M.toList . simpleMap . parseLog <$> Annex.Branch.get (remoteContentIdentifierLogFile config k) diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs index 7dfbb473d5..c139e7aa3e 100644 --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -19,6 +19,7 @@ - after the other remote redundantly set foo +x, it was unset, - and so foo currently has no value. - + - Copyright 2014-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -35,6 +36,7 @@ module Logs.MetaData ( import Annex.Common import Types.MetaData +import Types.RemoteState import Annex.MetaData.StandardFields import Annex.VectorClock import qualified Annex.Branch @@ -84,8 +86,8 @@ getCurrentMetaData' getlogfile k = do Unknown -> 0 showts = formatPOSIXTime "%F@%H-%M-%S" -getCurrentRemoteMetaData :: UUID -> Key -> Annex RemoteMetaData -getCurrentRemoteMetaData u k = extractRemoteMetaData u <$> +getCurrentRemoteMetaData :: RemoteStateHandle -> Key -> Annex RemoteMetaData +getCurrentRemoteMetaData (RemoteStateHandle u) k = extractRemoteMetaData u <$> getCurrentMetaData' remoteMetaDataLogFile k {- Adds in some metadata, which can override existing values, or unset @@ -116,9 +118,10 @@ addMetaDataClocked' getlogfile k d@(MetaData m) c where metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m -addRemoteMetaData :: Key -> RemoteMetaData -> Annex () -addRemoteMetaData k m = do - addMetaData' remoteMetaDataLogFile k (fromRemoteMetaData m) +addRemoteMetaData :: Key -> RemoteStateHandle -> MetaData -> Annex () +addRemoteMetaData k (RemoteStateHandle u) m = + addMetaData' remoteMetaDataLogFile k $ fromRemoteMetaData $ + RemoteMetaData u m getMetaDataLog :: Key -> Annex (Log MetaData) getMetaDataLog key = do diff --git a/Logs/Remote.hs b/Logs/Remote.hs index 28d673b302..02350dbb83 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -1,6 +1,6 @@ {- git-annex remote log - - - Copyright 2011 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -22,10 +22,10 @@ import qualified Annex.Branch import Types.Remote import Logs import Logs.UUIDBased +import Logs.Remote.Pure +import Annex.SpecialRemote.Config import qualified Data.Map as M -import Data.Char -import qualified Data.Attoparsec.ByteString.Lazy as A import Data.ByteString.Builder {- Adds or updates a remote's config in the log. -} @@ -34,74 +34,10 @@ configSet u cfg = do c <- liftIO currentVectorClock Annex.Branch.change remoteLog $ buildLogOld (byteString . encodeBS . showConfig) - . changeLog c u cfg + . changeLog c u (removeSameasInherited cfg) . parseLogOld remoteConfigParser {- Map of remotes by uuid containing key/value config maps. -} readRemoteLog :: Annex (M.Map UUID RemoteConfig) -readRemoteLog = simpleMap . parseLogOld remoteConfigParser +readRemoteLog = calcRemoteConfigMap <$> Annex.Branch.get remoteLog - -remoteConfigParser :: A.Parser RemoteConfig -remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString - -showConfig :: RemoteConfig -> String -showConfig = unwords . configToKeyVal - -{- Given Strings like "key=value", generates a RemoteConfig. -} -keyValToConfig :: [String] -> RemoteConfig -keyValToConfig ws = M.fromList $ map (/=/) ws - where - (/=/) s = (k, v) - where - k = takeWhile (/= '=') s - v = configUnEscape $ drop (1 + length k) s - -configToKeyVal :: M.Map String String -> [String] -configToKeyVal m = map toword $ sort $ M.toList m - where - toword (k, v) = k ++ "=" ++ configEscape v - -configEscape :: String -> String -configEscape = concatMap escape - where - escape c - | isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";" - | otherwise = [c] - -configUnEscape :: String -> String -configUnEscape = unescape - where - unescape [] = [] - unescape (c:rest) - | c == '&' = entity rest - | otherwise = c : unescape rest - entity s - | not (null num) && ";" `isPrefixOf` r = - chr (Prelude.read num) : unescape rest - | otherwise = - '&' : unescape s - where - num = takeWhile isNumber s - r = drop (length num) s - rest = drop 1 r - -{- for quickcheck -} -prop_isomorphic_configEscape :: String -> Bool -prop_isomorphic_configEscape s = s == (configUnEscape . configEscape) s - -prop_parse_show_Config :: RemoteConfig -> Bool -prop_parse_show_Config c - -- whitespace and '=' are not supported in config keys - | any (\k -> any isSpace k || elem '=' k) (M.keys c) = True - | any (any excluded) (M.keys c) = True - | any (any excluded) (M.elems c) = True - | otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c - where - normalize v = sort . M.toList <$> v - a ~~ b = normalize a == normalize b - -- limit to ascii alphanumerics for simplicity; characters not - -- allowed by the current character set in the config may not - -- round-trip in an identical representation due to the use of the - -- filesystem encoding. - excluded ch = not (isAlphaNum ch) || not (isAscii ch) diff --git a/Logs/RemoteState.hs b/Logs/RemoteState.hs index 4d7708bac8..2c1c742ce7 100644 --- a/Logs/RemoteState.hs +++ b/Logs/RemoteState.hs @@ -11,6 +11,7 @@ module Logs.RemoteState ( ) where import Annex.Common +import Types.RemoteState import Logs import Logs.UUIDBased import qualified Annex.Branch @@ -23,8 +24,8 @@ import Data.ByteString.Builder type RemoteState = String -setRemoteState :: UUID -> Key -> RemoteState -> Annex () -setRemoteState u k s = do +setRemoteState :: RemoteStateHandle -> Key -> RemoteState -> Annex () +setRemoteState (RemoteStateHandle u) k s = do c <- liftIO currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (remoteStateLogFile config k) $ @@ -33,8 +34,8 @@ setRemoteState u k s = do buildRemoteState :: Log RemoteState -> Builder buildRemoteState = buildLogNew (byteString . encodeBS) -getRemoteState :: UUID -> Key -> Annex (Maybe RemoteState) -getRemoteState u k = do +getRemoteState :: RemoteStateHandle -> Key -> Annex (Maybe RemoteState) +getRemoteState (RemoteStateHandle u) k = do config <- Annex.getGitConfig extract . parseRemoteState <$> Annex.Branch.get (remoteStateLogFile config k) diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 24c9ba1887..50e708826a 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -40,8 +40,8 @@ remote = RemoteType , importSupported = importIsSupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do let this = Remote { uuid = u -- adb operates over USB or wifi, so is not as cheap @@ -90,6 +90,7 @@ gen r u c gc = do ] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } return $ Just $ specialRemote c (simplyPrepare $ store serial adir) diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index a16f8eceff..0e49cb1837 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -52,8 +52,8 @@ list _autoinit = do r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown) return [r] -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r _ c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r _ c gc rs = do cst <- remoteCost gc expensiveRemoteCost return $ Just Remote { uuid = bitTorrentUUID @@ -85,6 +85,7 @@ gen r _ c gc = do , getInfo = return [] , claimUrl = Just (pure . isSupportedUrl) , checkUrl = Just checkTorrentUrl + , remoteStateHandle = rs } downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index d00b34a72c..ba06939c8e 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -44,8 +44,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do bupr <- liftIO $ bup2GitRemote buprepo cst <- remoteCost gc $ if bupLocal buprepo @@ -86,6 +86,7 @@ gen r u c gc = do , getInfo = return [("repo", buprepo)] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this buprepo) diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 250fd90293..f34d045f61 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -39,8 +39,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do cst <- remoteCost gc $ if ddarLocal ddarrepo then nearlyCheapRemoteCost @@ -85,6 +85,7 @@ gen r u c gc = do , getInfo = return [("repo", ddarRepoLocation ddarrepo)] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc) specialcfg = (specialRemoteCfg c) diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 868cad1dbe..e5b397b3e9 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -45,8 +45,8 @@ remote = RemoteType , importSupported = importIsSupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do cst <- remoteCost gc cheapRemoteCost let chunkconfig = getChunkConfig c return $ Just $ specialRemote c @@ -97,11 +97,12 @@ gen r u c gc = do , appendonly = False , availability = LocallyAvailable , remotetype = remote - , mkUnavailable = gen r u c $ - gc { remoteAnnexDirectory = Just "/dev/null" } + , mkUnavailable = gen r u c + (gc { remoteAnnexDirectory = Just "/dev/null" }) rs , getInfo = return [("directory", dir)] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } where dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc diff --git a/Remote/External.hs b/Remote/External.hs index c0ab167110..f6444e678b 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -50,8 +50,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs -- readonly mode only downloads urls; does not use external program | remoteAnnexReadOnly gc = do cst <- remoteCost gc expensiveRemoteCost @@ -67,7 +67,7 @@ gen r u c gc exportUnsupported exportUnsupported | otherwise = do - external <- newExternal externaltype u c gc + external <- newExternal externaltype u c gc (Just rs) Annex.addCleanup (RemoteCleanup u) $ stopExternal external cst <- getCost external r gc avail <- getAvailability external r gc @@ -132,11 +132,12 @@ gen r u c gc , availability = avail , remotetype = remote { exportSupported = cheapexportsupported } - , mkUnavailable = gen r u c $ - gc { remoteAnnexExternalType = Just "!dne!" } + , mkUnavailable = gen r u c + (gc { remoteAnnexExternalType = Just "!dne!" }) rs , getInfo = togetinfo , claimUrl = toclaimurl , checkUrl = tocheckurl + , remoteStateHandle = rs } return $ Just $ specialRemote c (simplyPrepare tostore) @@ -155,10 +156,10 @@ externalSetup _ mu _ c gc = do c'' <- case M.lookup "readonly" c of Just v | isTrue v == Just True -> do - setConfig (remoteConfig (fromJust (M.lookup "name" c)) "readonly") (boolConfig True) + setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True) return c' _ -> do - external <- newExternal externaltype u c' gc + external <- newExternal externaltype u c' gc Nothing handleRequest external INITREMOTE Nothing $ \resp -> case resp of INITREMOTE_SUCCESS -> result () INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg @@ -174,7 +175,7 @@ checkExportSupported c gc = do let externaltype = fromMaybe (giveup "Specify externaltype=") $ remoteAnnexExternalType gc <|> M.lookup "externaltype" c checkExportSupported' - =<< newExternal externaltype NoUUID c gc + =<< newExternal externaltype NoUUID c gc Nothing checkExportSupported' :: External -> Annex Bool checkExportSupported' external = go `catchNonAsync` (const (return False)) @@ -414,11 +415,16 @@ handleRequest' st external req mp responsehandler <$> preferredContentMapRaw send $ VALUE expr handleRemoteRequest (SETSTATE key state) = - setRemoteState (externalUUID external) key state - handleRemoteRequest (GETSTATE key) = do - state <- fromMaybe "" - <$> getRemoteState (externalUUID external) key - send $ VALUE state + case externalRemoteStateHandle external of + Just h -> setRemoteState h key state + Nothing -> senderror "cannot send SETSTATE here" + handleRemoteRequest (GETSTATE key) = + case externalRemoteStateHandle external of + Just h -> do + state <- fromMaybe "" + <$> getRemoteState h key + send $ VALUE state + Nothing -> senderror "cannot send GETSTATE here" handleRemoteRequest (SETURLPRESENT key url) = setUrlPresent key url handleRemoteRequest (SETURLMISSING key url) = @@ -432,17 +438,17 @@ handleRequest' st external req mp responsehandler send (VALUE "") -- end of list handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg handleRemoteRequest (INFO msg) = showInfo msg - handleRemoteRequest (VERSION _) = - sendMessage st external (ERROR "too late to send VERSION") + handleRemoteRequest (VERSION _) = senderror "too late to send VERSION" handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err send = sendMessage st external + senderror = sendMessage st external . ERROR credstorage setting = CredPairStorage { credPairFile = base , credPairEnvironment = (base ++ "login", base ++ "password") - , credPairRemoteKey = setting + , credPairRemoteField = setting } where base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 7c13b79d83..9c1e207aa1 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -37,7 +37,7 @@ import Types.StandardGroups (PreferredContentExpression) import Utility.Metered (BytesProcessed(..)) import Types.Transfer (Direction(..)) import Config.Cost (Cost) -import Types.Remote (RemoteConfig) +import Types.Remote (RemoteConfig, RemoteStateHandle) import Types.Export import Types.Availability (Availability(..)) import Types.Key @@ -57,16 +57,18 @@ data External = External , externalLastPid :: TVar PID , externalDefaultConfig :: RemoteConfig , externalGitConfig :: RemoteGitConfig + , externalRemoteStateHandle :: Maybe RemoteStateHandle } -newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex External -newExternal externaltype u c gc = liftIO $ External +newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External +newExternal externaltype u c gc rs = liftIO $ External <$> pure externaltype <*> pure u <*> atomically (newTVar []) <*> atomically (newTVar 0) <*> pure c <*> pure gc + <*> pure rs type ExternalType = String diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 931a1491f3..0c4d42cf57 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -65,16 +65,16 @@ remote = RemoteType , importSupported = importUnsupported } -chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -chainGen gcryptr u c gc = do +chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +chainGen gcryptr u c 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 + gen r' u c gc rs -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen baser u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen baser u c 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 @@ -82,7 +82,7 @@ gen baser u c gc = 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 + _ -> 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 @@ -95,15 +95,15 @@ gen baser u c gc = do case (Git.remoteName baser, v) of (Just remotename, Just c') -> do setGcryptEncryption c' remotename - setConfig (remoteConfig baser "uuid") (fromUUID u') + storeUUIDIn (remoteConfig baser "uuid") u' setConfig (ConfigKey $ Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid - gen' r u' c' gc + gen' r u' c' gc rs _ -> do warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r return Nothing -gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen' r u c gc = do +gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen' r u c gc rs = do cst <- remoteCost gc $ if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost (rsynctransport, rsyncurl) <- rsyncTransportToObjects r gc @@ -137,6 +137,7 @@ gen' r u c gc = do , getInfo = gitRepoInfo this , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this rsyncopts) @@ -183,7 +184,7 @@ unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not suppor gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c where - remotename = fromJust (M.lookup "name" c) + remotename = fromJust (lookupName c) go Nothing = giveup "Specify gitrepo=" go (Just gitrepo) = do (c', _encsetup) <- encryptionSetup c gc diff --git a/Remote/Git.hs b/Remote/Git.hs index e184aebca2..7bdab21a1b 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -32,6 +32,7 @@ import qualified Annex.Content import qualified Annex.BranchState import qualified Annex.Branch import qualified Annex.Url as Url +import qualified Annex.SpecialRemote.Config as SpecialRemote import Utility.Tmp import Config import Config.Cost @@ -120,7 +121,7 @@ gitSetup (Enable _) (Just u) _ c _ = do inRepo $ Git.Command.run [ Param "remote" , Param "add" - , Param $ fromMaybe (giveup "no name") (M.lookup "name" c) + , Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c) , Param $ fromMaybe (giveup "no location") (M.lookup "location" c) ] return (c, u) @@ -145,17 +146,17 @@ configRead autoinit r = do (False, _, NoUUID) -> tryGitConfigRead autoinit r _ -> return r -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c 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 - | Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc + | remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc rs + | Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c 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 + Just addr -> Remote.P2P.chainGen addr r u c gc rs where defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost go st cst = Just new @@ -189,14 +190,15 @@ gen r u c gc , appendonly = False , availability = availabilityCalc r , remotetype = remote - , mkUnavailable = unavailable r u c gc + , mkUnavailable = unavailable r u c gc rs , getInfo = gitRepoInfo new , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } -unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -unavailable r u c gc = gen r' u c gc +unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +unavailable r = gen r' where r' = case Git.location r of Git.Local { Git.gitdir = d } -> diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 3c43ab1592..d629788199 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -57,8 +57,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do -- 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 @@ -70,10 +70,10 @@ gen r u c gc = do h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc cst <- remoteCost gc expensiveRemoteCost return $ Just $ specialRemote' specialcfg c - (simplyPrepare $ store u h) - (simplyPrepare $ retrieve u h) + (simplyPrepare $ store rs h) + (simplyPrepare $ retrieve rs h) (simplyPrepare $ remove h) - (simplyPrepare $ checkKey u h) + (simplyPrepare $ checkKey rs h) (this cst) where this cst = Remote @@ -109,6 +109,7 @@ gen r u c gc = do , getInfo = gitRepoInfo (this cst) , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } specialcfg = (specialRemoteCfg c) -- chunking would not improve git-lfs @@ -157,7 +158,7 @@ mySetup _ mu _ c gc = do return (c'', u) where url = fromMaybe (giveup "Specify url=") (M.lookup "url" c) - remotename = fromJust (M.lookup "name" c) + remotename = fromJust (lookupName c) data LFSHandle = LFSHandle { downloadEndpoint :: Maybe LFS.Endpoint @@ -327,8 +328,8 @@ extractKeySize k | isEncKey k = Nothing | otherwise = keySize k -mkUploadRequest :: UUID -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer) -mkUploadRequest u k content = case (extractKeySha256 k, extractKeySize k) of +mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer) +mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of (Just sha256, Just size) -> ret sha256 size (_, Just size) -> do @@ -355,12 +356,12 @@ mkUploadRequest u k content = case (extractKeySha256 k, extractKeySize k) of } return (req, sha256, size) - remembersha256 sha256 = setRemoteState u k (T.unpack sha256) - rememberboth sha256 size = setRemoteState u k $ + remembersha256 sha256 = setRemoteState rs k (T.unpack sha256) + rememberboth sha256 size = setRemoteState rs k $ show size ++ " " ++ T.unpack sha256 -mkDownloadRequest :: UUID -> Key -> Annex (Maybe (LFS.TransferRequest, LFS.SHA256, Integer)) -mkDownloadRequest u k = case (extractKeySha256 k, extractKeySize k) of +mkDownloadRequest :: RemoteStateHandle -> Key -> Annex (Maybe (LFS.TransferRequest, LFS.SHA256, Integer)) +mkDownloadRequest rs k = case (extractKeySha256 k, extractKeySize k) of (Just sha256, Just size) -> ret sha256 size (_, Just size) -> remembersha256 >>= \case @@ -383,8 +384,8 @@ mkDownloadRequest u k = case (extractKeySha256 k, extractKeySize k) of , LFS.req_objects = [obj] } return $ Just (req, sha256, size) - remembersha256 = fmap T.pack <$> getRemoteState u k - rememberboth = maybe Nothing parse <$> getRemoteState u k + remembersha256 = fmap T.pack <$> getRemoteState rs k + rememberboth = maybe Nothing parse <$> getRemoteState rs k where parse s = case words s of [ssize, ssha256] -> do @@ -392,11 +393,11 @@ mkDownloadRequest u k = case (extractKeySha256 k, extractKeySize k) of return (T.pack ssha256, size) _ -> Nothing -store :: UUID -> TVar LFSHandle -> Storer -store u h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case +store :: RemoteStateHandle -> TVar LFSHandle -> Storer +store rs h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case Nothing -> return False Just endpoint -> flip catchNonAsync failederr $ do - (req, sha256, size) <- mkUploadRequest u k src + (req, sha256, size) <- mkUploadRequest rs k src sendTransferRequest req endpoint >>= \case Left err -> do warning err @@ -424,10 +425,10 @@ store u h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \cas warning (show e) return False -retrieve :: UUID -> TVar LFSHandle -> Retriever -retrieve u h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case +retrieve :: RemoteStateHandle -> TVar LFSHandle -> Retriever +retrieve rs h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case Nothing -> giveup "unable to connect to git-lfs endpoint" - Just endpoint -> mkDownloadRequest u k >>= \case + Just endpoint -> mkDownloadRequest rs k >>= \case Nothing -> giveup "unable to download this object from git-lfs" Just (req, sha256, size) -> sendTransferRequest req endpoint >>= \case Left err -> giveup (show err) @@ -448,10 +449,10 @@ retrieve u h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h uo <- getUrlOptions liftIO $ downloadConduit p req dest uo -checkKey :: UUID -> TVar LFSHandle -> CheckPresent -checkKey u h key = getLFSEndpoint LFS.RequestDownload h >>= \case +checkKey :: RemoteStateHandle -> TVar LFSHandle -> CheckPresent +checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case Nothing -> giveup "unable to connect to git-lfs endpoint" - Just endpoint -> mkDownloadRequest u key >>= \case + Just endpoint -> mkDownloadRequest rs key >>= \case -- Unable to find enough information to request the key -- from git-lfs, so it's not present there. Nothing -> return False diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 1d49ff50c0..6823179d12 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -39,8 +39,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost where new cst = Just $ specialRemote' specialcfg c (prepareStore this) @@ -83,6 +83,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost [ ("glacier vault", getVault c) ] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } specialcfg = (specialRemoteCfg c) -- Disabled until jobList gets support for chunks. @@ -104,7 +105,7 @@ glacierSetup' ss u mcreds c gc = do gitConfigSpecialRemote u fullconfig [("glacier", "true")] return (fullconfig, u) where - remotename = fromJust (M.lookup "name" c) + remotename = fromJust (lookupName c) defvault = remotename ++ "-" ++ fromUUID u defaults = M.fromList [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.Glacier) diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs index 031bdf8d85..3ab2063e4b 100644 --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -23,7 +23,7 @@ creds :: UUID -> CredPairStorage creds u = CredPairStorage { credPairFile = fromUUID u , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") - , credPairRemoteKey = "s3creds" + , credPairRemoteField = "s3creds" } data Service = S3 | Glacier diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index b810a72a91..a011d9b5a2 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -25,6 +25,7 @@ import Logs.Chunk import Utility.Metered import Crypto (EncKey) import Backend (isStableKey) +import Annex.SpecialRemote.Config import qualified Data.ByteString.Lazy as L import qualified Data.Map as M @@ -49,11 +50,11 @@ noChunks _ = False getChunkConfig :: RemoteConfig -> ChunkConfig getChunkConfig m = - case M.lookup "chunksize" m of + case M.lookup chunksizeField m of Nothing -> case M.lookup "chunk" m of Nothing -> NoChunks Just v -> readsz UnpaddedChunks v "chunk" - Just v -> readsz LegacyChunks v "chunksize" + Just v -> readsz LegacyChunks v chunksizeField where readsz c v f = case readSize dataUnits v of Just size diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index e2715403af..42df0e41bc 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -29,6 +29,7 @@ import Config import Crypto import Types.Crypto import qualified Annex +import Annex.SpecialRemote.Config -- Used to ensure that encryption has been set up before trying to -- eg, store creds in the remote config that would need to use the @@ -55,7 +56,7 @@ encryptionSetup c gc = do maybe (genCipher cmd) (updateCipher cmd) (extractCipher c) where -- The type of encryption - encryption = M.lookup "encryption" c + encryption = M.lookup encryptionField c -- Generate a new cipher, depending on the chosen encryption scheme genCipher cmd = case encryption of _ | hasEncryptionConfig c -> cannotchange @@ -68,7 +69,7 @@ encryptionSetup c gc = do Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key _ -> giveup $ "Specify " ++ intercalate " or " - (map ("encryption=" ++) + (map ((encryptionField ++ "=") ++) ["none","shared","hybrid","pubkey", "sharedpubkey"]) ++ "." key = fromMaybe (giveup "Specify keyid=...") $ M.lookup "keyid" c @@ -130,30 +131,30 @@ remoteCipher' c gc = go $ extractCipher c embedCreds :: RemoteConfig -> Bool embedCreds c = case yesNo =<< M.lookup "embedcreds" c of Just v -> v - Nothing -> isJust (M.lookup "cipherkeys" c) && isJust (M.lookup "cipher" c) + Nothing -> isJust (M.lookup cipherkeysField c) && isJust (M.lookup cipherField c) {- Gets encryption Cipher, and key encryptor. -} cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey)) cipherKey c gc = fmap make <$> remoteCipher c gc where make ciphertext = (ciphertext, encryptKey mac ciphertext) - mac = fromMaybe defaultMac $ M.lookup "mac" c >>= readMac + mac = fromMaybe defaultMac $ M.lookup macField c >>= readMac {- Stores an StorableCipher in a remote's configuration. -} storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig storeCipher cip = case cip of (SharedCipher t) -> addcipher t - (EncryptedCipher t _ ks) -> addcipher t . storekeys ks "cipherkeys" - (SharedPubKeyCipher t ks) -> addcipher t . storekeys ks "pubkeys" + (EncryptedCipher t _ ks) -> addcipher t . storekeys ks cipherkeysField + (SharedPubKeyCipher t ks) -> addcipher t . storekeys ks pubkeysField where - addcipher t = M.insert "cipher" (toB64bs t) + addcipher t = M.insert cipherField (toB64bs t) storekeys (KeyIds l) n = M.insert n (intercalate "," l) {- Extracts an StorableCipher from a remote's configuration. -} extractCipher :: RemoteConfig -> Maybe StorableCipher -extractCipher c = case (M.lookup "cipher" c, - M.lookup "cipherkeys" c <|> M.lookup "pubkeys" c, - M.lookup "encryption" c) of +extractCipher c = case (M.lookup cipherField c, + M.lookup cipherkeysField c <|> M.lookup pubkeysField c, + M.lookup encryptionField c) of (Just t, Just ks, encryption) | maybe True (== "hybrid") encryption -> Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks) (Just t, Just ks, Just "pubkey") -> @@ -167,13 +168,15 @@ extractCipher c = case (M.lookup "cipher" c, readkeys = KeyIds . splitc ',' isEncrypted :: RemoteConfig -> Bool -isEncrypted c = case M.lookup "encryption" c of +isEncrypted c = case M.lookup encryptionField c of Just "none" -> False Just _ -> True Nothing -> hasEncryptionConfig c hasEncryptionConfig :: RemoteConfig -> Bool -hasEncryptionConfig c = M.member "cipher" c || M.member "cipherkeys" c || M.member "pubkeys" c +hasEncryptionConfig c = M.member cipherField c + || M.member cipherkeysField c + || M.member pubkeysField c describeEncryption :: RemoteConfig -> String describeEncryption c = case extractCipher c of diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 2ae1343752..399163ba23 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -99,8 +99,8 @@ adjustExportImportRemoteType rt = rt { setup = setup' } -- | Adjust a remote to support exporttree=yes and importree=yes. -- -- Note that all remotes with importree=yes also have exporttree=yes. -adjustExportImport :: Remote -> Annex Remote -adjustExportImport r = case M.lookup "exporttree" (config r) of +adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote +adjustExportImport r rs = case M.lookup "exporttree" (config r) of Nothing -> return $ notexport r Just c -> case yesNo c of Just True -> ifM (isExportSupported r) @@ -136,7 +136,7 @@ adjustExportImport r = case M.lookup "exporttree" (config r) of let keycids k = do db <- getciddb ciddbv - liftIO $ ContentIdentifier.getContentIdentifiers db (uuid r') k + liftIO $ ContentIdentifier.getContentIdentifiers db rs k let checkpresent k loc = checkPresentExportWithContentIdentifier @@ -152,16 +152,16 @@ adjustExportImport r = case M.lookup "exporttree" (config r) of updateexportdb exportdb exportdbv oldks <- liftIO $ Export.getExportTreeKey exportdb loc oldcids <- liftIO $ concat - <$> mapM (ContentIdentifier.getContentIdentifiers db (uuid r')) oldks + <$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case Left err -> do warning err return False Right newcid -> do withExclusiveLock gitAnnexContentIdentifierLock $ do - liftIO $ ContentIdentifier.recordContentIdentifier db (uuid r') newcid k + liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k liftIO $ ContentIdentifier.flushDbQueue db - recordContentIdentifier (uuid r') newcid k + recordContentIdentifier rs newcid k return True , removeExport = \k loc -> removeExportWithContentIdentifier (importActions r') k loc diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 5325fc46a2..510793a8db 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -30,14 +30,17 @@ module Remote.Helper.Special ( specialRemoteCfg, specialRemote, specialRemote', + lookupName, module X ) where import Annex.Common import qualified Annex +import Annex.SpecialRemote.Config import Types.StoreRetrieve import Types.Remote import Crypto +import Annex.UUID import Config import Config.Cost import Utility.Metered @@ -70,7 +73,7 @@ gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex () gitConfigSpecialRemote u c cfgs = do forM_ cfgs $ \(k, v) -> setConfig (remoteConfig c k) v - setConfig (remoteConfig c "uuid") (fromUUID u) + storeUUIDIn (remoteConfig c "uuid") u -- RetrievalVerifiableKeysSecure unless overridden by git config. -- diff --git a/Remote/Hook.hs b/Remote/Hook.hs index fbba052bf8..83c5e8ebc0 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -35,8 +35,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost return $ Just $ specialRemote c (simplyPrepare $ store hooktype) @@ -70,11 +70,13 @@ gen r u c gc = do , appendonly = False , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u c $ - gc { remoteAnnexHookType = Just "!dne!" } + , mkUnavailable = gen r u c + (gc { remoteAnnexHookType = Just "!dne!" }) + rs , getInfo = return [("hooktype", hooktype)] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } where hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc diff --git a/Remote/List.hs b/Remote/List.hs index d4ed4dfe28..5f3016b257 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE CPP #-} - {- git-annex remote list - - - Copyright 2011,2012 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Remote.List where import qualified Data.Map as M @@ -15,6 +15,7 @@ import Annex.Common import qualified Annex import Logs.Remote import Types.Remote +import Types.RemoteState import Annex.UUID import Remote.Helper.Hooks import Remote.Helper.ReadOnly @@ -105,10 +106,12 @@ remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe R remoteGen m t g = do u <- getRepoUUID g gc <- Annex.getRemoteGitConfig g - let c = fromMaybe M.empty $ M.lookup u m - generate t g u c gc >>= \case + let cu = fromMaybe u $ remoteAnnexConfigUUID gc + let rs = RemoteStateHandle cu + let c = fromMaybe M.empty $ M.lookup cu m + generate t g u c gc rs >>= \case Nothing -> return Nothing - Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) + Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs {- Updates a local git Remote, re-reading its git config. -} updateRemote :: Remote -> Annex (Maybe Remote) diff --git a/Remote/P2P.hs b/Remote/P2P.hs index 17bd6fbb83..755de1631e 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -35,14 +35,14 @@ remote = RemoteType -- Remote.Git takes care of enumerating P2P remotes, -- and will call chainGen on them. , enumerate = const (return []) - , generate = \_ _ _ _ -> return Nothing + , generate = \_ _ _ _ _ -> return Nothing , setup = error "P2P remotes are set up using git-annex p2p" , exportSupported = exportUnsupported , importSupported = importUnsupported } -chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -chainGen addr r u c gc = do +chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +chainGen addr r u c gc rs = do connpool <- mkConnectionPool cst <- remoteCost gc veryExpensiveRemoteCost let protorunner = runProto u addr connpool @@ -76,6 +76,7 @@ chainGen addr r u c gc = do , getInfo = gitRepoInfo this , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } return (Just this) diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 1845c5aeb9..af26fbc757 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -54,8 +54,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost (transport, url) <- rsyncTransport gc $ fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc @@ -104,6 +104,7 @@ gen r u c gc = do , getInfo = return [("url", url)] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } where specialcfg = (specialRemoteCfg c) diff --git a/Remote/S3.hs b/Remote/S3.hs index 84b4ab5c63..97a94dc853 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -44,6 +44,7 @@ import qualified Git import qualified Annex import Config import Config.Cost +import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Http import Remote.Helper.Messages @@ -77,8 +78,8 @@ remote = RemoteType , importSupported = importIsSupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost info <- extractS3Info c hdl <- mkS3HandleVar c gc u @@ -87,9 +88,9 @@ gen r u c gc = do where new cst info hdl magic = Just $ specialRemote c (simplyPrepare $ store hdl this info magic) - (simplyPrepare $ retrieve hdl this c info) + (simplyPrepare $ retrieve hdl this rs c info) (simplyPrepare $ remove hdl this info) - (simplyPrepare $ checkKey hdl this c info) + (simplyPrepare $ checkKey hdl this rs c info) this where this = Remote @@ -107,23 +108,23 @@ gen r u c gc = do , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = ExportActions - { storeExport = storeExportS3 hdl this info magic + { storeExport = storeExportS3 hdl this rs info magic , retrieveExport = retrieveExportS3 hdl this info - , removeExport = removeExportS3 hdl this info + , removeExport = removeExportS3 hdl this rs info , checkPresentExport = checkPresentExportS3 hdl this info -- S3 does not have directories. , removeExportDirectory = Nothing - , renameExport = renameExportS3 hdl this info + , renameExport = renameExportS3 hdl this rs info } , importActions = ImportActions { listImportableContents = listImportableContentsS3 hdl this info - , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this info - , storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this info magic - , removeExportWithContentIdentifier = removeExportWithContentIdentifierS3 hdl this info + , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this rs info + , storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this rs info magic + , removeExportWithContentIdentifier = removeExportWithContentIdentifierS3 hdl this rs info , removeExportDirectoryWhenEmpty = Nothing , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierS3 hdl this info } - , whereisKey = Just (getPublicWebUrls u info c) + , whereisKey = Just (getPublicWebUrls u rs info c) , remoteFsck = Nothing , repairRepo = Nothing , config = c @@ -134,10 +135,11 @@ gen r u c gc = do , appendonly = versioning info , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc + , mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc rs , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info) , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } s3Setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) @@ -150,7 +152,7 @@ s3Setup' ss u mcreds c gc | configIA c = archiveorg | otherwise = defaulthost where - remotename = fromJust (M.lookup "name" c) + remotename = fromJust (lookupName c) defbucket = remotename ++ "-" ++ fromUUID u defaults = M.fromList [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.S3) @@ -188,7 +190,7 @@ s3Setup' ss u mcreds c gc -- IA acdepts x-amz-* as an alias for x-archive-* M.mapKeys (replace "x-archive-" "x-amz-") $ -- encryption does not make sense here - M.insert "encryption" "none" $ + M.insert encryptionField "none" $ M.insert "bucket" validbucket $ M.union c' $ -- special constraints on key names @@ -292,16 +294,16 @@ storeHelper info h magic f object p = liftIO $ case partSize info of {- Implemented as a fileRetriever, that uses conduit to stream the chunks - out to the file. Would be better to implement a byteRetriever, but - that is difficult. -} -retrieve :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> Retriever -retrieve hv r c info = fileRetriever $ \f k p -> withS3Handle hv $ \case +retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> Retriever +retrieve hv r rs c info = fileRetriever $ \f k p -> withS3Handle hv $ \case (Just h) -> - eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case + eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case Left failreason -> do warning failreason giveup "cannot download content" Right loc -> retrieveHelper info h loc f p Nothing -> - getPublicWebUrls' (uuid r) info c k >>= \case + getPublicWebUrls' (uuid r) rs info c k >>= \case Left failreason -> do warning failreason giveup "cannot download content" @@ -329,17 +331,17 @@ remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResource S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) return $ either (const False) (const True) res -checkKey :: S3HandleVar -> Remote -> RemoteConfig -> S3Info -> CheckPresent -checkKey hv r c info k = withS3Handle hv $ \case +checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> CheckPresent +checkKey hv r rs c info k = withS3Handle hv $ \case Just h -> do showChecking r - eitherS3VersionID info (uuid r) c k (T.pack $ bucketObject info k) >>= \case + eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case Left failreason -> do warning failreason giveup "cannot check content" Right loc -> checkKeyHelper info h loc Nothing -> - getPublicWebUrls' (uuid r) info c k >>= \case + getPublicWebUrls' (uuid r) rs info c k >>= \case Left failreason -> do warning failreason giveup "cannot check content" @@ -365,12 +367,12 @@ checkKeyHelper' info h o limit = liftIO $ runResourceT $ do where req = limit $ S3.headObject (bucket info) o -storeExportS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool -storeExportS3 hv r info magic f k loc p = fst - <$> storeExportS3' hv r info magic f k loc p +storeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool +storeExportS3 hv r rs info magic f k loc p = fst + <$> storeExportS3' hv r rs info magic f k loc p -storeExportS3' :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Bool, (Maybe S3Etag, Maybe S3VersionID)) -storeExportS3' hv r info magic f k loc p = withS3Handle hv $ \case +storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Bool, (Maybe S3Etag, Maybe S3VersionID)) +storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case Just h -> catchNonAsync (go h) (\e -> warning (show e) >> return (False, (Nothing, Nothing))) Nothing -> do warning $ needS3Creds (uuid r) @@ -379,7 +381,7 @@ storeExportS3' hv r info magic f k loc p = withS3Handle hv $ \case go h = do let o = T.pack $ bucketExportLocation info loc (metag, mvid) <- storeHelper info h magic f o p - setS3VersionID info (uuid r) k mvid + setS3VersionID info rs k mvid return (True, (metag, mvid)) retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool @@ -398,9 +400,9 @@ retrieveExportS3 hv r info _k loc f p = liftIO . Url.download p (geturl exportloc) f exportloc = bucketExportLocation info loc -removeExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool -removeExportS3 hv r info k loc = withS3Handle hv $ \case - Just h -> checkVersioning info (uuid r) k $ +removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex Bool +removeExportS3 hv r rs info k loc = withS3Handle hv $ \case + Just h -> checkVersioning info rs k $ catchNonAsync (go h) (\e -> warning (show e) >> return False) Nothing -> do warning $ needS3Creds (uuid r) @@ -422,11 +424,11 @@ checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case giveup "No S3 credentials configured" -- S3 has no move primitive; copy and delete. -renameExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) -renameExportS3 hv r info k src dest = Just <$> go +renameExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) +renameExportS3 hv r rs info k src dest = Just <$> go where go = withS3Handle hv $ \case - Just h -> checkVersioning info (uuid r) k $ + Just h -> checkVersioning info rs k $ catchNonAsync (go' h) (\_ -> return False) Nothing -> do warning $ needS3Creds (uuid r) @@ -542,8 +544,8 @@ mkImportableContentsVersioned info = build . groupfiles | otherwise = i : removemostrecent mtime rest -retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key) -retrieveExportWithContentIdentifierS3 hv r info loc cid dest mkkey p = withS3Handle hv $ \case +retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex (Maybe Key) -> MeterUpdate -> Annex (Maybe Key) +retrieveExportWithContentIdentifierS3 hv r rs info loc cid dest mkkey p = withS3Handle hv $ \case Nothing -> do warning $ needS3Creds (uuid r) return Nothing @@ -554,7 +556,7 @@ retrieveExportWithContentIdentifierS3 hv r info loc cid dest mkkey p = withS3Han mk <- mkkey case (mk, extractContentIdentifier cid o) of (Just k, Right vid) -> - setS3VersionID info (uuid r) k vid + setS3VersionID info rs k vid _ -> noop return mk where @@ -576,8 +578,8 @@ rewritePreconditionException a = catchJust (Url.matchStatusCodeException want) a -- -- When the bucket is not versioned, data loss can result. -- This is why that configuration requires --force to enable. -storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) -storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p +storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex (Either String ContentIdentifier) +storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecids p | versioning info = go -- FIXME Actual aws version that supports getting Etag for a store -- is not known; patch not merged yet. @@ -589,7 +591,7 @@ storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p Left "git-annex is built with too old a version of the aws library to support this operation" #endif where - go = storeExportS3' hv r info magic src k loc p >>= \case + go = storeExportS3' hv r rs info magic src k loc p >>= \case (False, _) -> return $ Left "failed to store content in S3 bucket" (True, (_, Just vid)) -> return $ Right $ mkS3VersionedContentIdentifier vid @@ -604,9 +606,9 @@ storeExportWithContentIdentifierS3 hv r info magic src k loc _overwritablecids p -- -- When the bucket is not versioned, data loss can result. -- This is why that configuration requires --force to enable. -removeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool -removeExportWithContentIdentifierS3 hv r info k loc _removeablecids = - removeExportS3 hv r info k loc +removeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool +removeExportWithContentIdentifierS3 hv r rs info k loc _removeablecids = + removeExportS3 hv r rs info k loc checkPresentExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierS3 hv r info _k loc knowncids = @@ -979,11 +981,11 @@ s3Info c info = catMaybes showstorageclass (S3.OtherStorageClass t) = T.unpack t showstorageclass sc = show sc -getPublicWebUrls :: UUID -> S3Info -> RemoteConfig -> Key -> Annex [URLString] -getPublicWebUrls u info c k = either (const []) id <$> getPublicWebUrls' u info c k +getPublicWebUrls :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex [URLString] +getPublicWebUrls u rs info c k = either (const []) id <$> getPublicWebUrls' u rs info c k -getPublicWebUrls' :: UUID -> S3Info -> RemoteConfig -> Key -> Annex (Either String [URLString]) -getPublicWebUrls' u info c k +getPublicWebUrls' :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex (Either String [URLString]) +getPublicWebUrls' u rs info c k | not (public info) = return $ Left $ "S3 bucket does not allow public access; " ++ needS3Creds u | exportTree c = if versioning info @@ -999,7 +1001,7 @@ getPublicWebUrls' u info c k Nothing -> return nopublicurl where nopublicurl = Left "No publicurl is configured for this remote" - getversionid url = getS3VersionIDPublicUrls url info u k >>= \case + getversionid url = getS3VersionIDPublicUrls url info rs k >>= \case [] -> return (Left "Remote is configured to use versioning, but no S3 version ID is recorded for this key") l -> return (Right l) @@ -1100,20 +1102,20 @@ extractContentIdentifier (ContentIdentifier v) o = "#" -> Left (T.drop 1 t) _ -> Right (mkS3VersionID o (Just t)) -setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex () -setS3VersionID info u k vid - | versioning info = maybe noop (setS3VersionID' u k) vid +setS3VersionID :: S3Info -> RemoteStateHandle -> Key -> Maybe S3VersionID -> Annex () +setS3VersionID info rs k vid + | versioning info = maybe noop (setS3VersionID' rs k) vid | otherwise = noop -setS3VersionID' :: UUID -> Key -> S3VersionID -> Annex () -setS3VersionID' u k vid = addRemoteMetaData k $ - RemoteMetaData u (updateMetaData s3VersionField v emptyMetaData) +setS3VersionID' :: RemoteStateHandle -> Key -> S3VersionID -> Annex () +setS3VersionID' rs k vid = addRemoteMetaData k rs $ + updateMetaData s3VersionField v emptyMetaData where v = mkMetaValue (CurrentlySet True) (formatS3VersionID vid) -getS3VersionID :: UUID -> Key -> Annex [S3VersionID] -getS3VersionID u k = do - (RemoteMetaData _ m) <- getCurrentRemoteMetaData u k +getS3VersionID :: RemoteStateHandle -> Key -> Annex [S3VersionID] +getS3VersionID rs k = do + (RemoteMetaData _ m) <- getCurrentRemoteMetaData rs k return $ mapMaybe parseS3VersionID $ map unwrap $ S.toList $ metaDataValues s3VersionField m where @@ -1122,9 +1124,9 @@ getS3VersionID u k = do s3VersionField :: MetaField s3VersionField = mkMetaFieldUnchecked "V" -eitherS3VersionID :: S3Info -> UUID -> RemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID)) -eitherS3VersionID info u c k fallback - | versioning info = getS3VersionID u k >>= return . \case +eitherS3VersionID :: S3Info -> RemoteStateHandle -> RemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID)) +eitherS3VersionID info rs c k fallback + | versioning info = getS3VersionID rs k >>= return . \case [] -> if exportTree c then Left "Remote is configured to use versioning, but no S3 version ID is recorded for this key" else Right (Left fallback) @@ -1140,9 +1142,9 @@ s3VersionIDPublicUrl mk info (S3VersionID obj vid) = concat , T.unpack vid -- version ID is "url ready" so no escaping needed ] -getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> UUID -> Key -> Annex [URLString] -getS3VersionIDPublicUrls mk info u k = - map (s3VersionIDPublicUrl mk info) <$> getS3VersionID u k +getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> RemoteStateHandle -> Key -> Annex [URLString] +getS3VersionIDPublicUrls mk info rs k = + map (s3VersionIDPublicUrl mk info) <$> getS3VersionID rs k -- Enable versioning on the bucket can only be done at init time; -- setting versioning in a bucket that git-annex has already exported @@ -1188,9 +1190,9 @@ enableBucketVersioning ss info _ _ _ = do -- were created without versioning, some unversioned files exported to -- them, and then versioning enabled, and this is to avoid data loss in -- those cases. -checkVersioning :: S3Info -> UUID -> Key -> Annex Bool -> Annex Bool -checkVersioning info u k a - | versioning info = getS3VersionID u k >>= \case +checkVersioning :: S3Info -> RemoteStateHandle -> Key -> Annex Bool -> Annex Bool +checkVersioning info rs k a + | versioning info = getS3VersionID rs k >>= \case [] -> do warning $ "Remote is configured to use versioning, but no S3 version ID is recorded for this key, so it cannot safely be modified." return False diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index b2e3035bd0..b169a380f4 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -61,8 +61,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost hdl <- liftIO $ TahoeHandle <$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc) @@ -71,18 +71,18 @@ gen r u c gc = do { uuid = u , cost = cst , name = Git.repoDescribe r - , storeKey = store u hdl - , retrieveKeyFile = retrieve u hdl + , storeKey = store rs hdl + , retrieveKeyFile = retrieve rs hdl , retrieveKeyFileCheap = \_ _ _ -> return False -- Tahoe cryptographically verifies content. , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = remove , lockContent = Nothing - , checkPresent = checkKey u hdl + , checkPresent = checkKey rs hdl , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported - , whereisKey = Just (getWhereisKey u) + , whereisKey = Just (getWhereisKey rs) , remoteFsck = Nothing , repairRepo = Nothing , config = c @@ -97,6 +97,7 @@ gen r u c gc = do , getInfo = return [] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) @@ -119,14 +120,14 @@ tahoeSetup _ mu _ c _ = do furlk = "introducer-furl" missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." -store :: UUID -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool -store u hdl k _f _p = sendAnnex k noop $ \src -> +store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool +store rs hdl k _f _p = sendAnnex k noop $ \src -> parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe (return False) - (\cap -> storeCapability u k cap >> return True) + (\cap -> storeCapability rs k cap >> return True) -retrieve :: UUID -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -retrieve u hdl k _f d _p = unVerified $ go =<< getCapability u k +retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +retrieve rs hdl k _f d _p = unVerified $ go =<< getCapability rs k where go Nothing = return False go (Just cap) = liftIO $ requestTahoe hdl "get" [Param cap, File d] @@ -136,8 +137,8 @@ remove _k = do warning "content cannot be removed from tahoe remote" return False -checkKey :: UUID -> TahoeHandle -> Key -> Annex Bool -checkKey u hdl k = go =<< getCapability u k +checkKey :: RemoteStateHandle -> TahoeHandle -> Key -> Annex Bool +checkKey rs hdl k = go =<< getCapability rs k where go Nothing = return False go (Just cap) = liftIO $ do @@ -233,14 +234,14 @@ tahoeParams :: TahoeConfigDir -> String -> [CommandParam] -> [CommandParam] tahoeParams configdir command params = Param "-d" : File configdir : Param command : params -storeCapability :: UUID -> Key -> Capability -> Annex () -storeCapability u k cap = setRemoteState u k cap +storeCapability :: RemoteStateHandle -> Key -> Capability -> Annex () +storeCapability rs k cap = setRemoteState rs k cap -getCapability :: UUID -> Key -> Annex (Maybe Capability) -getCapability u k = getRemoteState u k +getCapability :: RemoteStateHandle -> Key -> Annex (Maybe Capability) +getCapability rs k = getRemoteState rs k -getWhereisKey :: UUID -> Key -> Annex [String] -getWhereisKey u k = disp <$> getCapability u k +getWhereisKey :: RemoteStateHandle -> Key -> Annex [String] +getWhereisKey rs k = disp <$> getCapability rs k where disp Nothing = [] disp (Just c) = [c] diff --git a/Remote/Web.hs b/Remote/Web.hs index 71309f1586..b3dab374e7 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -40,8 +40,8 @@ list _autoinit = do r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown) return [r] -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r _ c gc = do +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r _ c gc rs = do cst <- remoteCost gc expensiveRemoteCost return $ Just Remote { uuid = webUUID @@ -74,6 +74,7 @@ gen r _ c gc = do , getInfo = return [] , claimUrl = Nothing -- implicitly claims all urls , checkUrl = Nothing + , remoteStateHandle = rs } downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index a17579841d..9204495317 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -50,8 +50,8 @@ remote = RemoteType , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) -gen r u c gc = new <$> remoteCost gc expensiveRemoteCost +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost where new cst = Just $ specialRemote c (prepareDAV this $ store chunkconfig) @@ -95,11 +95,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost , appendonly = False , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc + , mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc rs , getInfo = includeCredsInfo c (davCreds u) $ [("url", fromMaybe "unknown" (M.lookup "url" c))] , claimUrl = Nothing , checkUrl = Nothing + , remoteStateHandle = rs } chunkconfig = getChunkConfig c @@ -341,7 +342,7 @@ davCreds :: UUID -> CredPairStorage davCreds u = CredPairStorage { credPairFile = fromUUID u , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD") - , credPairRemoteKey = "davcreds" + , credPairRemoteField = "davcreds" } {- Content-Type to use for files uploaded to WebDAV. -} diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 9e37bc1f3a..c19be3cbbf 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -246,6 +246,7 @@ data RemoteGitConfig = RemoteGitConfig , remoteAnnexRetry :: Maybe Integer , remoteAnnexRetryDelay :: Maybe Seconds , remoteAnnexAllowUnverifiedDownloads :: Bool + , remoteAnnexConfigUUID :: Maybe UUID {- These settings are specific to particular types of remotes - including special remotes. -} @@ -308,6 +309,7 @@ extractRemoteGitConfig r remotename = do <$> getmayberead "retrydelay" , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe ("security-allow-unverified-downloads") + , remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid" , remoteAnnexShell = getmaybe "shell" , remoteAnnexSshOptions = getoptions "ssh-options" , remoteAnnexRsyncOptions = getoptions "rsync-options" diff --git a/Types/Remote.hs b/Types/Remote.hs index 18ae88a022..0604228f86 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -10,10 +10,11 @@ {-# LANGUAGE RankNTypes #-} module Types.Remote - ( RemoteConfigKey + ( RemoteConfigField , RemoteConfig , RemoteTypeA(..) , RemoteA(..) + , RemoteStateHandle , SetupStage(..) , Availability(..) , Verification(..) @@ -36,6 +37,7 @@ import Types.UUID import Types.GitConfig import Types.Availability import Types.Creds +import Types.RemoteState import Types.UrlContents import Types.NumCopies import Types.Export @@ -47,9 +49,9 @@ import Utility.SafeCommand import Utility.Url import Utility.DataUnits -type RemoteConfigKey = String +type RemoteConfigField = String -type RemoteConfig = M.Map RemoteConfigKey String +type RemoteConfig = M.Map RemoteConfigField String data SetupStage = Init | Enable RemoteConfig @@ -61,7 +63,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 -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)) + , generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a)) -- initializes or enables a remote , setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) -- check if a remote of this type is able to support export @@ -151,6 +153,7 @@ data RemoteA a = Remote -- its contents, without downloading the full content. -- Throws an exception if the url is inaccessible. , checkUrl :: Maybe (URLString -> a UrlContents) + , remoteStateHandle :: RemoteStateHandle } instance Show (RemoteA a) where diff --git a/Types/RemoteState.hs b/Types/RemoteState.hs new file mode 100644 index 0000000000..6e3cd23b74 --- /dev/null +++ b/Types/RemoteState.hs @@ -0,0 +1,19 @@ +{- git-annex remote state handle type + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.RemoteState where + +import Types.UUID + +{- When per-remote state, its UUID is used to identify it. + - + - However, sameas remotes mean that two different Remote implementations + - can be used for the same underlying data store. To avoid them using + - state in conflicting ways, a different UUID needs to be used for each + - additional sameas remote. + -} +newtype RemoteStateHandle = RemoteStateHandle UUID diff --git a/doc/git-annex-initremote.mdwn b/doc/git-annex-initremote.mdwn index 13471cccc8..8340827f6d 100644 --- a/doc/git-annex-initremote.mdwn +++ b/doc/git-annex-initremote.mdwn @@ -43,6 +43,25 @@ want to use `git annex renameremote`. and re-run with `--fast`, which causes it to use a lower-quality source of randomness. (Ie, /dev/urandom instead of /dev/random) +* `--sameas=remote` + + Use this when the new special remote uses the same underlying storage + as some other remote. This will result in the new special remote having + the same uuid as the specified remote, and either can be used to access + the same content. + + The `remote` can be the name of a git remote, or the description + or uuid of any git-annex repository. + + When using this option, the new remote inherits the encryption settings + of the existing remote, so you should not specify any encryption + parameters. No other configuration is inherited from the existing remote. + + This will only work if both remotes use the underlying storage in + compatible ways. See this page for information about known + compatabilities. + + # COMMON CONFIGURATION PARAMETERS * `encryption` diff --git a/doc/git-annex-renameremote.mdwn b/doc/git-annex-renameremote.mdwn index 13d2a007b7..676edf1676 100644 --- a/doc/git-annex-renameremote.mdwn +++ b/doc/git-annex-renameremote.mdwn @@ -10,7 +10,7 @@ git annex renameremote `name|uuid|desc newname` Changes the name that is used to enable a special remote. -Normally the current name is used to identify the special remote, +Normally the current name is used to identify the special remote to rename, but its uuid or description can also be used. This is especially useful when an old special remote used a name, and now you diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index bea502faed..c7a6517ba2 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1268,6 +1268,11 @@ Remotes are configured using these settings in `.git/config`. git-annex caches UUIDs of remote repositories here. +* `remote..annex-config-uuid` + + Used for some special remotes, points to a different special remote + configuration to use. + * `remote..annex-retry`, `annex.retry` Configure retries of failed transfers on a per-remote and general diff --git a/doc/internals.mdwn b/doc/internals.mdwn index b8394fc1ca..0745004c74 100644 --- a/doc/internals.mdwn +++ b/doc/internals.mdwn @@ -277,7 +277,7 @@ For example: These log files store per-remote content identifiers for keys. A given key may have any number of content identifiers. -The format is a timestamp, followed by the uuid or the remote, +The format is a timestamp, followed by the uuid of the remote, followed by the content identifiers which are separated by colons. If a content identifier contains a colon or \r or \n, it will be base64 encoded. Base64 encoded values are indicated by prefixing them with "!". diff --git a/doc/tips/multiple_remotes_accessing_the_same_data_store.mdwn b/doc/tips/multiple_remotes_accessing_the_same_data_store.mdwn new file mode 100644 index 0000000000..e3cda30e28 --- /dev/null +++ b/doc/tips/multiple_remotes_accessing_the_same_data_store.mdwn @@ -0,0 +1,58 @@ +A remote configures git-annex with a way to access a particular data +store. Sometimes, there's more than one way for git-annex to access the +same underlying data store. It then makes sense to have multiple remotes. + +The most common and easy case of this is when the data store is itself a +git-annex repository. For example, using git-annex on your laptop, you +might add a ssh remote which works from anywhere. But, when you're located +on the same LAN as the server, it might be faster or simpler to use a +different ssh url. + + git remote add server someserver.example.com:/data + git remote add lanserver someserver.lan:/data + +git-annex is able to realize automatically that these two remotes both +access the same repository (by contacting the repository and looking up its +git-annex uuid). You can use git-annex to access which ever remote you +want to at a given time. + +[[Special_remotes]] don't store data in a git-annex repository. It's +possible to configure two special remotes that access the same underlying +data store, at least in theory. Whether it will work depends on how the +two special remotes store their data. If they don't use the same filename +(or whatever), it might not work. + +The case almost guaranteed to work is two special remotes of the same type, +and other configuration, but with different urls that point to the same +data store. For example, a [[special_remotes/git-lfs]] repository can be +accessed using http or ssh. So two git-lfs special remotes can be set up, +and both access the same data. + + git annex initremote lfs-ssh type=git-lfs encryption=shared url=git@example.com:repo + git annex initremote --sameas=lfs-ssh lfs-http type=git-lfs url=https://example.com/repo + +The `--sameas` parameter tells git-annex that the new special remote +uses the same data store as an existing special remote. Note that +the encryption= parameter, which is usually mandatory, is omitted. +The two necessarily encrypt data in the same way, so it will +inherit the encryption configuration. Other configuration is not inherited, +so if you need some parameter to initremote to make a special remote behave +a certian way, be sure to pass it to both. + +Finally, it's sometimes possible to access the same data stored in two +special remotes with different types. One combination that works is +a [[special_remotes/directory]] special remote +and a [[special_remotes/rsync]] special remote. + + git annex initremote dir type=directory encryption=none directory=/foo + git annex initremote --sameas=dir rsync type=rsync rsyncurl=localhost:/foo + +If a combination does not work, git-annex will be unable to access files +in one remote or the other, it could get into a scrambled mess. So it's +best to test a a combination carefully before you start using it for real. +If you find combinations that work, please edit this page to list them. + +## known working combinations + +* directory and rsync + diff --git a/doc/todo/git-lfs_special_remote_simpler_setup.mdwn b/doc/todo/git-lfs_special_remote_simpler_setup.mdwn index 678a0c3627..7ca0b65f5d 100644 --- a/doc/todo/git-lfs_special_remote_simpler_setup.mdwn +++ b/doc/todo/git-lfs_special_remote_simpler_setup.mdwn @@ -17,6 +17,11 @@ make enableremote with a new url= add that as urlN=. [[support_multiple_special_remotes_with_same_uuid]] would solve it, perhaps in a cleaner way. +> If each url is treated as a separate special remote (which makes a lot of sense +> by analogy with how regular git remotes work), then +> [[support_multiple_special_remotes_with_same_uuid]] could be used to +> solve this. + Problem: The user might go in and change the remote's url to point to some other server with a different git-lfs backend. In fact, they could already do so! Remembering the urls actually would let the special remote detect diff --git a/doc/todo/support_multiple_special_remotes_with_same_uuid/comment_12_704637f56a74a0f561798ae398e1470b._comment b/doc/todo/support_multiple_special_remotes_with_same_uuid/comment_12_704637f56a74a0f561798ae398e1470b._comment new file mode 100644 index 0000000000..eabad462a2 --- /dev/null +++ b/doc/todo/support_multiple_special_remotes_with_same_uuid/comment_12_704637f56a74a0f561798ae398e1470b._comment @@ -0,0 +1,35 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 12""" + date="2019-10-11T19:56:12Z" + content=""" +Looking over all my comments now that I have an implementatation.. + +`git annex dead` on a sameas remote name marks the parent remote dead. +I think this is ok; dead means the content is gone, so which remote is used +to access it is immaterial; they're all dead. + +sameas loops are not a problem, it only looks up the sameas-uuid value +once, will not loop. + +old git-annex are prevented from enabling a sameas remote, since it has no +name= + +old git-annex with an enabled sameas remote will see the annex-uuid of the +parent, and treat it as the parent. Some git config values needed to use +the parent may not be set, or may potentially be set differently than for +the parent. Unlikely to cause any bad behavior, other than the remote not +working. + +encrypted data and legacy chunking is inherited, and cannot be overridden + +RemoteConfig always contains any inherited parameters of a sameas remote. +Logs.Remote.configSet filters those out. + +Logs.Remote.configSet is a little bit less safe; if its caller passed the +RemoteConfig from a sameas remote, it needs to make sure to not pass the +uuid of the parent remote, or it will overwrite the wrong config. All calls +to it handle that now. + +per-remote state still to be done. +"""]] diff --git a/git-annex.cabal b/git-annex.cabal index 15d08ced4b..4ddc4444be 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -304,7 +304,7 @@ Executable git-annex base (>= 4.11.1.0 && < 5.0), network-uri (>= 2.6), optparse-applicative (>= 0.14.1), - containers (>= 0.5.7.1), + containers (>= 0.5.8), exceptions (>= 0.6), stm (>= 2.3), mtl (>= 2), @@ -653,6 +653,7 @@ Executable git-annex Annex.ReplaceFile Annex.RemoteTrackingBranch Annex.SpecialRemote + Annex.SpecialRemote.Config Annex.Ssh Annex.TaggedPush Annex.Tmp @@ -896,6 +897,7 @@ Executable git-annex Logs.Presence Logs.Presence.Pure Logs.Remote + Logs.Remote.Pure Logs.RemoteState Logs.Schedule Logs.SingleValue @@ -993,6 +995,7 @@ Executable git-annex Types.NumCopies Types.RefSpec Types.Remote + Types.RemoteState Types.RepoVersion Types.ScheduledActivity Types.StandardGroups