From 16eb2f976c7b217ae23411ef10ec23f0592cc9bc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 7 Sep 2017 13:45:31 -0400 Subject: [PATCH] prevent exporttree=yes on remotes that don't support exports Don't allow "exporttree=yes" to be set when the special remote does not support exports. That would be confusing since the user would set up a special remote for exports, but `git annex export` to it would later fail. This commit was supported by the NSF-funded DataLad project. --- Annex/Content.hs | 2 +- Command/Export.hs | 2 +- Logs/Trust.hs | 2 +- Remote.hs | 1 + Remote/BitTorrent.hs | 13 ++++--- Remote/Bup.hs | 13 ++++--- Remote/Ddar.hs | 13 ++++--- Remote/Directory.hs | 18 ++++----- Remote/External.hs | 13 ++++--- Remote/GCrypt.hs | 13 ++++--- Remote/Git.hs | 13 ++++--- Remote/Glacier.hs | 13 ++++--- Remote/Helper/Export.hs | 85 ++++++++++++++++++++++++++--------------- Remote/Hook.hs | 13 ++++--- Remote/List.hs | 8 ++-- Remote/P2P.hs | 13 ++++--- Remote/Rsync.hs | 13 ++++--- Remote/S3.hs | 13 ++++--- Remote/Tahoe.hs | 13 ++++--- Remote/Web.hs | 13 ++++--- Remote/WebDAV.hs | 13 ++++--- Types/Remote.hs | 27 +++++++------ doc/todo/export.mdwn | 4 -- 23 files changed, 186 insertions(+), 145 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index b74b397537..0b665d4dcc 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -359,7 +359,7 @@ shouldVerify (RemoteVerify r) = <&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r))) -- Export remotes are not key/value stores, so always verify -- content from them even when verification is disabled. - <||> Types.Remote.exportSupported (Types.Remote.exportActions r) + <||> Types.Remote.isExportSupported r {- Checks if there is enough free disk space to download a key - to its temp file. diff --git a/Command/Export.hs b/Command/Export.hs index d397b2defa..2cf453ea14 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -77,7 +77,7 @@ exportTempName ek = ExportLocation $ seek :: ExportOptions -> CommandSeek seek o = do r <- getParsed (exportRemote o) - unlessM (exportSupported (exportActions r)) $ + unlessM (isExportSupported r) $ giveup "That remote does not support exports." new <- fromMaybe (giveup "unknown tree") <$> diff --git a/Logs/Trust.hs b/Logs/Trust.hs index 85b62ed743..54cafc9f43 100644 --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -67,7 +67,7 @@ trustMapLoad = do overrides <- Annex.getState Annex.forcetrust l <- remoteList -- Exports are never trusted, since they are not key/value stores. - exports <- filterM (Types.Remote.exportSupported . Types.Remote.exportActions) l + exports <- filterM Types.Remote.isExportSupported l let exportoverrides = M.fromList $ map (\r -> (Types.Remote.uuid r, UnTrusted)) exports logged <- trustMapRaw diff --git a/Remote.hs b/Remote.hs index 877c9f37de..8d826712c1 100644 --- a/Remote.hs +++ b/Remote.hs @@ -53,6 +53,7 @@ module Remote ( checkAvailable, isXMPPRemote, claimingUrl, + isExportSupported, ) where import Data.Ord diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 9a1be1c0ea..37594bd110 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -36,12 +36,13 @@ import qualified Data.ByteString.Lazy as B #endif remote :: RemoteType -remote = RemoteType { - typename = "bittorrent", - enumerate = list, - generate = gen, - setup = error "not supported" -} +remote = RemoteType + { typename = "bittorrent" + , enumerate = list + , generate = gen + , setup = error "not supported" + , exportSupported = exportUnsupported + } -- There is only one bittorrent remote, and it always exists. list :: Bool -> Annex [Git.Repo] diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 6ff2aa885a..4180cbb7d4 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -35,12 +35,13 @@ import Utility.Metered type BupRepo = String remote :: RemoteType -remote = RemoteType { - typename = "bup", - enumerate = const (findSpecialRemotes "buprepo"), - generate = gen, - setup = bupSetup -} +remote = RemoteType + { typename = "bup" + , enumerate = const (findSpecialRemotes "buprepo") + , generate = gen + , setup = bupSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index c5d02a4e6a..3949bf5698 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -30,12 +30,13 @@ data DdarRepo = DdarRepo } remote :: RemoteType -remote = RemoteType { - typename = "ddar", - enumerate = const (findSpecialRemotes "ddarrepo"), - generate = gen, - setup = ddarSetup -} +remote = RemoteType + { typename = "ddar" + , enumerate = const (findSpecialRemotes "ddarrepo") + , generate = gen + , setup = ddarSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 512ba1cef7..22413b7e9e 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -33,18 +33,19 @@ import Utility.Metered import Utility.Tmp remote :: RemoteType -remote = RemoteType { - typename = "directory", - enumerate = const (findSpecialRemotes "directory"), - generate = gen, - setup = exportableRemoteSetup directorySetup -} +remote = RemoteType + { typename = "directory" + , enumerate = const (findSpecialRemotes "directory") + , generate = gen + , setup = directorySetup + , exportSupported = exportIsSupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do cst <- remoteCost gc cheapRemoteCost let chunkconfig = getChunkConfig c - exportableRemote $ specialRemote c + return $ Just $ specialRemote c (prepareStore dir chunkconfig) (retrieve dir chunkconfig) (simplyPrepare $ remove dir) @@ -61,8 +62,7 @@ gen r u c gc = do , checkPresent = checkPresentDummy , checkPresentCheap = True , exportActions = ExportActions - { exportSupported = return True - , storeExport = storeExportDirectory dir + { storeExport = storeExportDirectory dir , retrieveExport = retrieveExportDirectory dir , removeExport = removeExportDirectory dir , checkPresentExport = checkPresentExportDirectory dir diff --git a/Remote/External.hs b/Remote/External.hs index fca60a995f..71a07d3ea7 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -40,12 +40,13 @@ import System.Log.Logger (debugM) import qualified Data.Map as M remote :: RemoteType -remote = RemoteType { - typename = "external", - enumerate = const (findSpecialRemotes "externaltype"), - generate = gen, - setup = externalSetup -} +remote = RemoteType + { typename = "external" + , enumerate = const (findSpecialRemotes "externaltype") + , generate = gen + , setup = externalSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index dd681a75c7..3270a1dc7e 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -52,14 +52,15 @@ import Utility.Gpg import Utility.SshHost remote :: RemoteType -remote = RemoteType { - typename = "gcrypt", +remote = RemoteType + { typename = "gcrypt" -- Remote.Git takes care of enumerating gcrypt remotes too, -- and will call our gen on them. - enumerate = const (return []), - generate = gen, - setup = gCryptSetup -} + , enumerate = const (return []) + , generate = gen + , setup = gCryptSetup + , exportSupported = exportUnsupported + } chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen gcryptr u c gc = do diff --git a/Remote/Git.hs b/Remote/Git.hs index 64fb51af83..02957fda29 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -67,12 +67,13 @@ import qualified Data.Map as M import Network.URI remote :: RemoteType -remote = RemoteType { - typename = "git", - enumerate = list, - generate = gen, - setup = gitSetup -} +remote = RemoteType + { typename = "git" + , enumerate = list + , generate = gen + , setup = gitSetup + , exportSupported = exportUnsupported + } list :: Bool -> Annex [Git.Repo] list autoinit = do diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 67e1b8b2e0..40a92c7009 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -30,12 +30,13 @@ type Vault = String type Archive = FilePath remote :: RemoteType -remote = RemoteType { - typename = "glacier", - enumerate = const (findSpecialRemotes "glacier"), - generate = gen, - setup = glacierSetup -} +remote = RemoteType + { typename = "glacier" + , enumerate = const (findSpecialRemotes "glacier") + , generate = gen + , setup = glacierSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs index a46f7bd6c4..58533155bb 100644 --- a/Remote/Helper/Export.hs +++ b/Remote/Helper/Export.hs @@ -5,11 +5,12 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE FlexibleInstances #-} + module Remote.Helper.Export where import Annex.Common import Types.Remote -import Types.Creds import Types.Backend import Types.Key import Backend @@ -19,24 +20,60 @@ import Database.Export import qualified Data.Map as M -- | Use for remotes that do not support exports. -exportUnsupported :: ExportActions Annex -exportUnsupported = ExportActions - { exportSupported = return False - , storeExport = \_ _ _ _ -> return False - , retrieveExport = \_ _ _ _ -> return (False, UnVerified) - , removeExport = \_ _ -> return False - , checkPresentExport = \_ _ -> return False - , renameExport = \_ _ _ -> return False - } +class HasExportUnsupported a where + exportUnsupported :: a --- | A remote that supports exports when configured with exporttree=yes, --- and otherwise does not. -exportableRemote :: Remote -> Annex (Maybe Remote) -exportableRemote r = case M.lookup "exporttree" (config r) of - Just "yes" -> do +instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where + exportUnsupported = \_ _ -> return False + +instance HasExportUnsupported (ExportActions Annex) where + exportUnsupported = ExportActions + { storeExport = \_ _ _ _ -> return False + , retrieveExport = \_ _ _ _ -> return (False, UnVerified) + , removeExport = \_ _ -> return False + , checkPresentExport = \_ _ -> return False + , renameExport = \_ _ _ -> return False + } + +exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool +exportIsSupported = \_ _ -> return True + +-- | Prevent or allow exporttree=yes when setting up a new remote, +-- depending on exportSupported and other configuration. +adjustExportableRemoteType :: RemoteType -> RemoteType +adjustExportableRemoteType rt = rt { setup = setup' } + where + setup' st mu cp c gc = do + let cont = setup rt st mu cp c gc + ifM (exportSupported rt c gc) + ( case st of + Init -> case M.lookup "exporttree" c of + Just "yes" | isEncrypted c -> + giveup "cannot enable both encryption and exporttree" + _ -> cont + Enable oldc + | M.lookup "exporttree" c /= M.lookup "exporttree" oldc -> + giveup "cannot change exporttree of existing special remote" + | otherwise -> cont + , case M.lookup "exporttree" c of + Just "yes" -> giveup "exporttree=yes is not supported by this special remote" + _ -> cont + ) + +-- | If the remote is exportSupported, and exporttree=yes, adjust the +-- remote to be an export. +adjustExportable :: Remote -> Annex Remote +adjustExportable r = case M.lookup "exporttree" (config r) of + Just "yes" -> ifM (isExportSupported r) + ( isexport + , notexport + ) + _ -> notexport + where + notexport = return $ r { exportActions = exportUnsupported } + isexport = do db <- openDb (uuid r) - - return $ Just $ r + return $ r -- Storing a key on an export would need a way to -- look up the file(s) that the currently exported -- tree uses for a key; there's not currently an @@ -87,17 +124,3 @@ exportableRemote r = case M.lookup "exporttree" (config r) of is <- getInfo r return (is++[("export", "yes")]) } - _ -> return $ Just $ r { exportActions = exportUnsupported } - -exportableRemoteSetup :: (SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)) -> SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) -exportableRemoteSetup setupaction st mu cp c gc = case st of - Init -> case M.lookup "exporttree" c of - Just "yes" | isEncrypted c -> - giveup "cannot enable both encryption and exporttree" - _ -> cont - Enable oldc - | M.lookup "exporttree" c /= M.lookup "exporttree" oldc -> - giveup "cannot change exporttree of existing special remote" - | otherwise -> cont - where - cont = setupaction st mu cp c gc diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 5be4339e33..d7c7eb6b82 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -26,12 +26,13 @@ type Action = String type HookName = String remote :: RemoteType -remote = RemoteType { - typename = "hook", - enumerate = const (findSpecialRemotes "hooktype"), - generate = gen, - setup = hookSetup -} +remote = RemoteType + { typename = "hook" + , enumerate = const (findSpecialRemotes "hooktype") + , generate = gen + , setup = hookSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do diff --git a/Remote/List.hs b/Remote/List.hs index a5e305622f..2dc5e4823a 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -18,6 +18,7 @@ import Types.Remote import Annex.UUID import Remote.Helper.Hooks import Remote.Helper.ReadOnly +import Remote.Helper.Export import qualified Git import qualified Git.Config @@ -42,7 +43,7 @@ import qualified Remote.Hook import qualified Remote.External remoteTypes :: [RemoteType] -remoteTypes = +remoteTypes = map adjustExportableRemoteType [ Remote.Git.remote , Remote.GCrypt.remote , Remote.P2P.remote @@ -100,8 +101,9 @@ remoteGen m t r = do u <- getRepoUUID r gc <- Annex.getRemoteGitConfig r let c = fromMaybe M.empty $ M.lookup u m - mrmt <- generate t r u c gc - return $ adjustReadOnly . addHooks <$> mrmt + generate t r u c gc >>= maybe + (return Nothing) + (Just <$$> adjustExportable . adjustReadOnly . addHooks) {- 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 f51b73b33e..be0d4589f2 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -34,14 +34,15 @@ import Control.Concurrent import Control.Concurrent.STM remote :: RemoteType -remote = RemoteType { - typename = "p2p", +remote = RemoteType + { typename = "p2p" -- Remote.Git takes care of enumerating P2P remotes, -- and will call chainGen on them. - enumerate = const (return []), - generate = \_ _ _ _ -> return Nothing, - setup = error "P2P remotes are set up using git-annex p2p" -} + , enumerate = const (return []) + , generate = \_ _ _ _ -> return Nothing + , setup = error "P2P remotes are set up using git-annex p2p" + , exportSupported = exportUnsupported + } chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) chainGen addr r u c gc = do diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 33485c78b8..79aebad6b8 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -44,12 +44,13 @@ import Utility.SshHost import qualified Data.Map as M remote :: RemoteType -remote = RemoteType { - typename = "rsync", - enumerate = const (findSpecialRemotes "rsyncurl"), - generate = gen, - setup = rsyncSetup -} +remote = RemoteType + { typename = "rsync" + , enumerate = const (findSpecialRemotes "rsyncurl") + , generate = gen + , setup = rsyncSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do diff --git a/Remote/S3.hs b/Remote/S3.hs index ffa6a11bbd..4b56cce296 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -54,12 +54,13 @@ import Utility.Url (checkBoth, managerSettings, closeManager) type BucketName = String remote :: RemoteType -remote = RemoteType { - typename = "S3", - enumerate = const (findSpecialRemotes "s3"), - generate = gen, - setup = s3Setup -} +remote = RemoteType + { typename = "S3" + , enumerate = const (findSpecialRemotes "s3") + , generate = gen + , setup = s3Setup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index b197edca2a..d3d52d7de6 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -52,12 +52,13 @@ type IntroducerFurl = String type Capability = String remote :: RemoteType -remote = RemoteType { - typename = "tahoe", - enumerate = const (findSpecialRemotes "tahoe"), - generate = gen, - setup = tahoeSetup -} +remote = RemoteType + { typename = "tahoe" + , enumerate = const (findSpecialRemotes "tahoe") + , generate = gen + , setup = tahoeSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = do diff --git a/Remote/Web.hs b/Remote/Web.hs index 45e8d1c229..f3580ca996 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -23,12 +23,13 @@ import Annex.Quvi import qualified Utility.Quvi as Quvi remote :: RemoteType -remote = RemoteType { - typename = "web", - enumerate = list, - generate = gen, - setup = error "not supported" -} +remote = RemoteType + { typename = "web" + , enumerate = list + , generate = gen + , setup = error "not supported" + , exportSupported = exportUnsupported + } -- There is only one web remote, and it always exists. -- (If the web should cease to exist, remove this module and redistribute diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 4c9552a6f9..4cc3c92e03 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -41,12 +41,13 @@ import Network.HTTP.Client (HttpExceptionContent(..), responseStatus) #endif remote :: RemoteType -remote = RemoteType { - typename = "webdav", - enumerate = const (findSpecialRemotes "webdav"), - generate = gen, - setup = webdavSetup -} +remote = RemoteType + { typename = "webdav" + , enumerate = const (findSpecialRemotes "webdav") + , generate = gen + , setup = webdavSetup + , exportSupported = exportUnsupported + } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = new <$> remoteCost gc expensiveRemoteCost diff --git a/Types/Remote.hs b/Types/Remote.hs index 6f0a312f4f..e2f36a55b6 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -19,6 +19,7 @@ module Types.Remote , Verification(..) , unVerified , ExportLocation(..) + , isExportSupported , ExportActions(..) ) where @@ -36,7 +37,7 @@ import Types.UrlContents import Types.NumCopies import Config.Cost import Utility.Metered -import Git.Types +import Git.Types (RemoteName) import Utility.SafeCommand import Utility.Url @@ -47,17 +48,19 @@ type RemoteConfig = M.Map RemoteConfigKey String data SetupStage = Init | Enable RemoteConfig {- There are different types of remotes. -} -data RemoteTypeA a = RemoteType { +data RemoteTypeA a = RemoteType -- human visible type name - typename :: String, + { typename :: String -- enumerates remotes of this type -- 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)), + , enumerate :: Bool -> a [Git.Repo] + -- generates a remote of this type from the current git config + , generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)) -- initializes or enables a remote - setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) -} + , setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) + -- check if a remote of this type is able to support export + , exportSupported :: RemoteConfig -> RemoteGitConfig -> a Bool + } instance Eq (RemoteTypeA a) where x == y = typename x == typename y @@ -161,12 +164,14 @@ unVerified a = do newtype ExportLocation = ExportLocation FilePath deriving (Show, Eq) -data ExportActions a = ExportActions - { exportSupported :: a Bool +isExportSupported :: RemoteA a -> a Bool +isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r) + +data ExportActions a = ExportActions -- Exports content to an ExportLocation. -- The exported file should not appear to be present on the remote -- until all of its contents have been transferred. - , storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a Bool + { storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a Bool -- Retrieves exported content to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) diff --git a/doc/todo/export.mdwn b/doc/todo/export.mdwn index abfa520059..8f5c3f8f1c 100644 --- a/doc/todo/export.mdwn +++ b/doc/todo/export.mdwn @@ -17,10 +17,6 @@ there need to be a new interface in supported remotes? Work is in progress. Todo list: -* initremote: Don't allow "exporttree=yes" to be set when the special remote - does not support exports. That would be confusing since the user would - set up a special remote for exports, but `git annex export` to it would - later fail.. * `git annex get --from export` works in the repo that exported to it, but in another repo, the export db won't be populated, so it won't work. Maybe just show a useful error message in this case?