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.
This commit is contained in:
Joey Hess 2017-09-07 13:45:31 -04:00
parent 45d30820ac
commit 16eb2f976c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
23 changed files with 186 additions and 145 deletions

View file

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

View file

@ -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") <$>

View file

@ -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

View file

@ -53,6 +53,7 @@ module Remote (
checkAvailable,
isXMPPRemote,
claimingUrl,
isExportSupported,
) where
import Data.Ord

View file

@ -36,11 +36,12 @@ 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.

View file

@ -35,11 +35,12 @@ 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)

View file

@ -30,11 +30,12 @@ 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)

View file

@ -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

View file

@ -40,11 +40,12 @@ 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)

View file

@ -52,13 +52,14 @@ 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)

View file

@ -67,11 +67,12 @@ 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]

View file

@ -30,11 +30,12 @@ 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)

View file

@ -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
class HasExportUnsupported a where
exportUnsupported :: a
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
exportUnsupported = \_ _ -> return False
instance HasExportUnsupported (ExportActions Annex) where
exportUnsupported = ExportActions
{ exportSupported = return False
, storeExport = \_ _ _ _ -> return False
{ storeExport = \_ _ _ _ -> return False
, retrieveExport = \_ _ _ _ -> return (False, UnVerified)
, removeExport = \_ _ -> return False
, checkPresentExport = \_ _ -> return False
, renameExport = \_ _ _ -> return False
}
-- | 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)
exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
exportIsSupported = \_ _ -> return True
return $ Just $ r
-- | 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 $ 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

View file

@ -26,11 +26,12 @@ 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)

View file

@ -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)

View file

@ -34,13 +34,14 @@ 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)

View file

@ -44,11 +44,12 @@ 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)

View file

@ -54,11 +54,12 @@ 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)

View file

@ -52,11 +52,12 @@ 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)

View file

@ -23,11 +23,12 @@ 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.

View file

@ -41,11 +41,12 @@ 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)

View file

@ -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,16 +48,18 @@ 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
@ -161,12 +164,14 @@ unVerified a = do
newtype ExportLocation = ExportLocation FilePath
deriving (Show, Eq)
isExportSupported :: RemoteA a -> a Bool
isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r)
data ExportActions a = ExportActions
{ exportSupported :: a Bool
-- 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.)

View file

@ -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?