From d910a94df7d6f5c87897c248586cb65523457f99 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 7 Sep 2017 13:45:31 -0400 Subject: 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. --- 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 ++++---- 17 files changed, 166 insertions(+), 127 deletions(-) (limited to 'Remote') diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 9a1be1c0e..37594bd11 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 6ff2aa885..4180cbb7d 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 c5d02a4e6..3949bf569 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 512ba1cef..22413b7e9 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 fca60a995..71a07d3ea 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 dd681a75c..3270a1dc7 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 64fb51af8..02957fda2 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 67e1b8b2e..40a92c700 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 a46f7bd6c..58533155b 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 - db <- openDb (uuid r) +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 + ) - return $ Just $ r +-- | 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 $ 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 5be4339e3..d7c7eb6b8 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 a5e305622..2dc5e4823 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 f51b73b33..be0d4589f 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 33485c78b..79aebad6b 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 ffa6a11bb..4b56cce29 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 b197edca2..d3d52d7de 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 45e8d1c22..f3580ca99 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 4c9552a6f..4cc3c92e0 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 -- cgit v1.2.3