implement exporttree=yes configuration
* Only export to remotes that were initialized to support it. * Prevent storing key/value on export remotes. * Prevent enabling exporttree=yes and encryption in the same remote. SetupStage Enable was changed to take the old RemoteConfig. This allowed only setting exporttree when initially setting up a remote, and not configuring it later after stuff might already be stored in the remote. Went with =yes rather than =true for consistency with other parts of git-annex. Changed docs accordingly. This commit was supported by the NSF-funded DataLad project.
This commit is contained in:
parent
a4328b49d2
commit
28e2cad849
14 changed files with 69 additions and 29 deletions
|
@ -37,14 +37,14 @@ remote = RemoteType {
|
|||
typename = "directory",
|
||||
enumerate = const (findSpecialRemotes "directory"),
|
||||
generate = gen,
|
||||
setup = directorySetup
|
||||
setup = exportableRemoteSetup directorySetup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||
gen r u c gc = do
|
||||
cst <- remoteCost gc cheapRemoteCost
|
||||
let chunkconfig = getChunkConfig c
|
||||
return $ Just $ specialRemote c
|
||||
return $ Just $ exportableRemote $ specialRemote c
|
||||
(prepareStore dir chunkconfig)
|
||||
(retrieve dir chunkconfig)
|
||||
(simplyPrepare $ remove dir)
|
||||
|
|
|
@ -111,7 +111,7 @@ gitSetup Init mu _ c _ = do
|
|||
if isNothing mu || mu == Just u
|
||||
then return (c, u)
|
||||
else error "git remote did not have specified uuid"
|
||||
gitSetup Enable (Just u) _ c _ = do
|
||||
gitSetup (Enable _) (Just u) _ c _ = do
|
||||
inRepo $ Git.Command.run
|
||||
[ Param "remote"
|
||||
, Param "add"
|
||||
|
@ -119,7 +119,7 @@ gitSetup Enable (Just u) _ c _ = do
|
|||
, Param $ fromMaybe (giveup "no location") (M.lookup "location" c)
|
||||
]
|
||||
return (c, u)
|
||||
gitSetup Enable Nothing _ _ _ = error "unable to enable git remote with no specified uuid"
|
||||
gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid"
|
||||
|
||||
{- It's assumed to be cheap to read the config of non-URL remotes, so this is
|
||||
- done each time git-annex is run in a way that uses remotes.
|
||||
|
|
|
@ -89,8 +89,9 @@ glacierSetup' ss u mcreds c gc = do
|
|||
(c', encsetup) <- encryptionSetup c gc
|
||||
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
when (ss == Init) $
|
||||
genVault fullconfig gc u
|
||||
case ss of
|
||||
Init -> genVault fullconfig gc u
|
||||
_ -> return ()
|
||||
gitConfigSpecialRemote u fullconfig "glacier" "true"
|
||||
return (fullconfig, u)
|
||||
where
|
||||
|
|
|
@ -15,6 +15,7 @@ module Remote.Helper.Encryptable (
|
|||
embedCreds,
|
||||
cipherKey,
|
||||
extractCipher,
|
||||
isEncrypted,
|
||||
describeEncryption,
|
||||
) where
|
||||
|
||||
|
@ -57,7 +58,7 @@ encryptionSetup c gc = do
|
|||
encryption = M.lookup "encryption" c
|
||||
-- Generate a new cipher, depending on the chosen encryption scheme
|
||||
genCipher cmd = case encryption of
|
||||
_ | M.member "cipher" c || M.member "cipherkeys" c || M.member "pubkeys" c -> cannotchange
|
||||
_ | hasEncryptionConfig c -> cannotchange
|
||||
Just "none" -> return (c, NoEncryption)
|
||||
Just "shared" -> encsetup $ genSharedCipher cmd
|
||||
-- hybrid encryption is the default when a keyid is
|
||||
|
@ -167,6 +168,15 @@ extractCipher c = case (M.lookup "cipher" c,
|
|||
where
|
||||
readkeys = KeyIds . splitc ','
|
||||
|
||||
isEncrypted :: RemoteConfig -> Bool
|
||||
isEncrypted c = case M.lookup "encryption" 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
|
||||
|
||||
describeEncryption :: RemoteConfig -> String
|
||||
describeEncryption c = case extractCipher c of
|
||||
Nothing -> "none"
|
||||
|
|
|
@ -9,7 +9,12 @@ module Remote.Helper.Export where
|
|||
|
||||
import Annex.Common
|
||||
import Types.Remote
|
||||
import Types.Creds
|
||||
import Remote.Helper.Encryptable (isEncrypted)
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
-- | Use for remotes that do not support exports.
|
||||
exportUnsupported :: ExportActions Annex
|
||||
exportUnsupported = ExportActions
|
||||
{ exportSupported = return False
|
||||
|
@ -19,3 +24,28 @@ exportUnsupported = ExportActions
|
|||
, checkPresentExport = \_ _ -> return False
|
||||
, renameExport = \_ _ _ -> return False
|
||||
}
|
||||
|
||||
-- | A remote that supports exports when configured with exporttree=yes,
|
||||
-- and otherwise does not.
|
||||
exportableRemote :: Remote -> Remote
|
||||
exportableRemote r = case M.lookup "exporttree" (config r) of
|
||||
Just "yes" -> r
|
||||
{ storeKey = \_ _ _ -> do
|
||||
warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it"
|
||||
return False
|
||||
}
|
||||
_ -> 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
|
||||
|
|
|
@ -129,8 +129,9 @@ s3Setup' ss u mcreds c gc
|
|||
(c', encsetup) <- encryptionSetup c gc
|
||||
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
when (ss == Init) $
|
||||
genBucket fullconfig gc u
|
||||
case ss of
|
||||
Init -> genBucket fullconfig gc u
|
||||
_ -> return ()
|
||||
use fullconfig
|
||||
|
||||
archiveorg = do
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue