diff options
Diffstat (limited to 'Remote')
-rw-r--r-- | Remote/Directory.hs | 4 | ||||
-rw-r--r-- | Remote/Git.hs | 4 | ||||
-rw-r--r-- | Remote/Glacier.hs | 5 | ||||
-rw-r--r-- | Remote/Helper/Encryptable.hs | 12 | ||||
-rw-r--r-- | Remote/Helper/Export.hs | 30 | ||||
-rw-r--r-- | Remote/S3.hs | 5 |
6 files changed, 51 insertions, 9 deletions
diff --git a/Remote/Directory.hs b/Remote/Directory.hs index e2e517b84..6adf6477a 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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) diff --git a/Remote/Git.hs b/Remote/Git.hs index 129d5e171..64fb51af8 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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. diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index b21167aaf..67e1b8b2e 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -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 diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 1fe6d75be..97e55a415 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -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" diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs index d623818e7..9bbbb1f59 100644 --- a/Remote/Helper/Export.hs +++ b/Remote/Helper/Export.hs @@ -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 diff --git a/Remote/S3.hs b/Remote/S3.hs index 341d14b4e..ffa6a11bb 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -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 |