summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
Diffstat (limited to 'Remote')
-rw-r--r--Remote/BitTorrent.hs15
-rw-r--r--Remote/Bup.hs15
-rw-r--r--Remote/Ddar.hs15
-rw-r--r--Remote/Directory.hs108
-rw-r--r--Remote/External.hs15
-rw-r--r--Remote/GCrypt.hs15
-rw-r--r--Remote/Git.hs19
-rw-r--r--Remote/Glacier.hs20
-rw-r--r--Remote/Helper/Encryptable.hs12
-rw-r--r--Remote/Helper/Export.hs126
-rw-r--r--Remote/Hook.hs15
-rw-r--r--Remote/List.hs8
-rw-r--r--Remote/P2P.hs15
-rw-r--r--Remote/Rsync.hs15
-rw-r--r--Remote/S3.hs20
-rw-r--r--Remote/Tahoe.hs15
-rw-r--r--Remote/Web.hs15
-rw-r--r--Remote/WebDAV.hs15
18 files changed, 361 insertions, 117 deletions
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index 2f29f5baa..37594bd11 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -26,6 +26,7 @@ import Backend.URL
import Annex.Perms
import Annex.UUID
import qualified Annex.Url as Url
+import Remote.Helper.Export
import Network.URI
@@ -35,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]
@@ -61,6 +63,7 @@ gen r _ c gc =
, lockContent = Nothing
, checkPresent = checkKey
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 3a2d67bc8..4180cbb7d 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -25,6 +25,7 @@ import Config.Cost
import qualified Remote.Helper.Ssh as Ssh
import Remote.Helper.Special
import Remote.Helper.Messages
+import Remote.Helper.Export
import Utility.Hash
import Utility.UserInfo
import Annex.UUID
@@ -34,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
@@ -61,6 +63,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = bupLocal buprepo
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 2f8c3b345..3949bf569 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -19,6 +19,7 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
+import Remote.Helper.Export
import Annex.Ssh
import Annex.UUID
import Utility.SshHost
@@ -29,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
@@ -60,6 +62,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = ddarLocal ddarrepo
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 2452c42e2..22413b7e9 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -1,6 +1,6 @@
{- A "remote" that is just a filesystem directory.
-
- - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -25,18 +25,21 @@ import Config.Cost
import Config
import Utility.FileMode
import Remote.Helper.Special
+import Remote.Helper.Export
import qualified Remote.Directory.LegacyChunked as Legacy
import Annex.Content
import Annex.UUID
import Utility.Metered
+import Utility.Tmp
remote :: RemoteType
-remote = RemoteType {
- typename = "directory",
- enumerate = const (findSpecialRemotes "directory"),
- generate = gen,
- setup = 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
@@ -58,6 +61,13 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = True
+ , exportActions = ExportActions
+ { storeExport = storeExportDirectory dir
+ , retrieveExport = retrieveExportDirectory dir
+ , removeExport = removeExportDirectory dir
+ , checkPresentExport = checkPresentExportDirectory dir
+ , renameExport = renameExportDirectory dir
+ }
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -111,24 +121,21 @@ getLocation d k = do
storeDir :: FilePath -> Key -> FilePath
storeDir d k = addTrailingPathSeparator $ d </> hashDirLower def k </> keyFile k
-{- Where we store temporary data for a key, in the directory, as it's being
- - written. -}
-tmpDir :: FilePath -> Key -> FilePath
-tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
-
{- Check if there is enough free disk space in the remote's directory to
- store the key. Note that the unencrypted key size is checked. -}
prepareStore :: FilePath -> ChunkConfig -> Preparer Storer
-prepareStore d chunkconfig = checkPrepare checker
+prepareStore d chunkconfig = checkPrepare (checkDiskSpaceDirectory d)
(byteStorer $ store d chunkconfig)
where
- checker k = do
- annexdir <- fromRepo gitAnnexObjectDir
- samefilesystem <- liftIO $ catchDefaultIO False $
- (\a b -> deviceID a == deviceID b)
- <$> getFileStatus d
- <*> getFileStatus annexdir
- checkDiskSpace (Just d) k 0 samefilesystem
+
+checkDiskSpaceDirectory :: FilePath -> Key -> Annex Bool
+checkDiskSpaceDirectory d k = do
+ annexdir <- fromRepo gitAnnexObjectDir
+ samefilesystem <- liftIO $ catchDefaultIO False $
+ (\a b -> deviceID a == deviceID b)
+ <$> getFileStatus d
+ <*> getFileStatus annexdir
+ checkDiskSpace (Just d) k 0 samefilesystem
store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
store d chunkconfig k b p = liftIO $ do
@@ -141,7 +148,7 @@ store d chunkconfig k b p = liftIO $ do
finalizeStoreGeneric tmpdir destdir
return True
where
- tmpdir = tmpDir d k
+ tmpdir = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
destdir = storeDir d k
{- Passed a temp directory that contains the files that should be placed
@@ -211,11 +218,66 @@ removeDirGeneric topdir dir = do
checkKey :: FilePath -> ChunkConfig -> CheckPresent
checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
-checkKey d _ k = liftIO $
- ifM (anyM doesFileExist (locations d k))
+checkKey d _ k = checkPresentGeneric d (locations d k)
+
+checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool
+checkPresentGeneric d ps = liftIO $
+ ifM (anyM doesFileExist ps)
( return True
, ifM (doesDirectoryExist d)
( return False
, giveup $ "directory " ++ d ++ " is not accessible"
)
)
+
+storeExportDirectory :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do
+ createDirectoryIfMissing True (takeDirectory dest)
+ -- Write via temp file so that checkPresentGeneric will not
+ -- see it until it's fully stored.
+ viaTmp (\tmp () -> withMeteredFile src p (L.writeFile tmp)) dest ()
+ return True
+ where
+ dest = exportPath d loc
+
+retrieveExportDirectory :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
+retrieveExportDirectory d _k loc dest p = unVerified $ liftIO $ catchBoolIO $ do
+ withMeteredFile src p (L.writeFile dest)
+ return True
+ where
+ src = exportPath d loc
+
+removeExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool
+removeExportDirectory d _k loc = liftIO $ do
+ nukeFile src
+ removeExportLocation d loc
+ return True
+ where
+ src = exportPath d loc
+
+checkPresentExportDirectory :: FilePath -> Key -> ExportLocation -> Annex Bool
+checkPresentExportDirectory d _k loc =
+ checkPresentGeneric d [exportPath d loc]
+
+renameExportDirectory :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex Bool
+renameExportDirectory d _k oldloc newloc = liftIO $ catchBoolIO $ do
+ createDirectoryIfMissing True (takeDirectory dest)
+ renameFile src dest
+ removeExportLocation d oldloc
+ return True
+ where
+ src = exportPath d oldloc
+ dest = exportPath d newloc
+
+exportPath :: FilePath -> ExportLocation -> FilePath
+exportPath d (ExportLocation loc) = d </> loc
+
+{- Removes the ExportLocation directory and its parents, so long as
+ - they're empty, up to but not including the topdir. -}
+removeExportLocation :: FilePath -> ExportLocation -> IO ()
+removeExportLocation topdir (ExportLocation loc) = go (Just loc) (Right ())
+ where
+ go _ (Left _e) = return ()
+ go Nothing _ = return ()
+ go (Just loc') _ = go (upFrom loc')
+ =<< tryIO (removeDirectory $ exportPath topdir (ExportLocation loc'))
diff --git a/Remote/External.hs b/Remote/External.hs
index 32b95e9bb..71a07d3ea 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -18,6 +18,7 @@ import Config
import Git.Config (isTrue, boolConfig)
import Git.Env
import Remote.Helper.Special
+import Remote.Helper.Export
import Remote.Helper.ReadOnly
import Remote.Helper.Messages
import Utility.Metered
@@ -39,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
@@ -85,6 +87,7 @@ gen r u c gc
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = towhereis
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 2ccc47ad8..3270a1dc7 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -38,6 +38,7 @@ import Remote.Helper.Git
import Remote.Helper.Encryptable
import Remote.Helper.Special
import Remote.Helper.Messages
+import Remote.Helper.Export
import qualified Remote.Helper.Ssh as Ssh
import Utility.Metered
import Annex.UUID
@@ -51,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
@@ -114,6 +116,7 @@ gen' r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = repoCheap r
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Git.hs b/Remote/Git.hs
index b48b48b52..02957fda2 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -50,6 +50,7 @@ import Utility.Batch
import Utility.SimpleProtocol
import Remote.Helper.Git
import Remote.Helper.Messages
+import Remote.Helper.Export
import qualified Remote.Helper.Ssh as Ssh
import qualified Remote.GCrypt
import qualified Remote.P2P
@@ -66,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
@@ -110,7 +112,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"
@@ -118,7 +120,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.
@@ -157,6 +159,7 @@ gen r u c gc
, lockContent = Just (lockKey new)
, checkPresent = inAnnex new
, checkPresentCheap = repoCheap r
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = if Git.repoIsUrl r
then Nothing
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index c2f9bcf12..40a92c700 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -18,6 +18,7 @@ import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Messages
+import Remote.Helper.Export
import qualified Remote.Helper.AWS as AWS
import Creds
import Utility.Metered
@@ -29,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
@@ -57,6 +59,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -87,8 +90,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
new file mode 100644
index 000000000..58533155b
--- /dev/null
+++ b/Remote/Helper/Export.hs
@@ -0,0 +1,126 @@
+{- exports to remotes
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE FlexibleInstances #-}
+
+module Remote.Helper.Export where
+
+import Annex.Common
+import Types.Remote
+import Types.Backend
+import Types.Key
+import Backend
+import Remote.Helper.Encryptable (isEncrypted)
+import Database.Export
+
+import qualified Data.Map as M
+
+-- | Use for remotes that do not support exports.
+class HasExportUnsupported a where
+ exportUnsupported :: a
+
+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 $ 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
+ -- inexpensive way to do that (getExportLocation
+ -- only finds files that have been stored on the
+ -- export already).
+ { storeKey = \_ _ _ -> do
+ warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it"
+ return False
+ -- Keys can be retrieved, but since an export
+ -- is not a true key/value store, the content of
+ -- the key has to be able to be strongly verified.
+ , retrieveKeyFile = \k _af dest p ->
+ if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
+ then do
+ locs <- liftIO $ getExportLocation db k
+ case locs of
+ [] -> do
+ warning "unknown export location"
+ return (False, UnVerified)
+ (l:_) -> retrieveExport (exportActions r) k l dest p
+ else do
+ warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
+ return (False, UnVerified)
+ , retrieveKeyFileCheap = \_ _ _ -> return False
+ -- Remove all files a key was exported to.
+ , removeKey = \k -> do
+ locs <- liftIO $ getExportLocation db k
+ oks <- forM locs $ \loc -> do
+ ok <- removeExport (exportActions r) k loc
+ when ok $
+ liftIO $ removeExportLocation db k loc
+ return ok
+ liftIO $ flushDbQueue db
+ return (and oks)
+ -- Can't lock content on exports, since they're
+ -- not key/value stores, and someone else could
+ -- change what's exported to a file at any time.
+ , lockContent = Nothing
+ -- Check if any of the files a key was exported
+ -- to are present. This doesn't guarantee the
+ -- export contains the right content.
+ , checkPresent = \k ->
+ anyM (checkPresentExport (exportActions r) k)
+ =<< liftIO (getExportLocation db k)
+ , mkUnavailable = return Nothing
+ , getInfo = do
+ is <- getInfo r
+ return (is++[("export", "yes")])
+ }
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 0ebbf9139..d7c7eb6b8 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -16,6 +16,7 @@ import Config.Cost
import Annex.UUID
import Remote.Helper.Special
import Remote.Helper.Messages
+import Remote.Helper.Export
import Utility.Env
import Messages.Progress
@@ -25,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
@@ -51,6 +53,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
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 118262b3c..be0d4589f 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -24,6 +24,7 @@ import Annex.UUID
import Config
import Config.Cost
import Remote.Helper.Git
+import Remote.Helper.Export
import Messages.Progress
import Utility.Metered
import Utility.AuthToken
@@ -33,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
@@ -57,6 +59,7 @@ chainGen addr r u c gc = do
, lockContent = Just (lock u addr connpool)
, checkPresent = checkpresent u addr connpool
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 4fc55d725..79aebad6b 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -28,6 +28,7 @@ import Annex.UUID
import Annex.Ssh
import Remote.Helper.Special
import Remote.Helper.Messages
+import Remote.Helper.Export
import Remote.Rsync.RsyncUrl
import Crypto
import Utility.Rsync
@@ -43,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
@@ -73,6 +75,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/S3.hs b/Remote/S3.hs
index c05831b0b..4b56cce29 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -39,6 +39,7 @@ import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Http
import Remote.Helper.Messages
+import Remote.Helper.Export
import qualified Remote.Helper.AWS as AWS
import Creds
import Annex.UUID
@@ -53,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
@@ -84,6 +86,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Just (getWebUrls info)
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -127,8 +130,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
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index e4686f2f2..d3d52d7de 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -34,6 +34,7 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
+import Remote.Helper.Export
import Annex.UUID
import Annex.Content
import Logs.RemoteState
@@ -51,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
@@ -75,6 +77,7 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkKey u hdl
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Just (getWhereisKey u)
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Web.hs b/Remote/Web.hs
index be2f265e0..f3580ca99 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -10,6 +10,7 @@ module Remote.Web (remote, getWebUrls) where
import Annex.Common
import Types.Remote
import Remote.Helper.Messages
+import Remote.Helper.Export
import qualified Git
import qualified Git.Construct
import Annex.Content
@@ -22,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
@@ -50,6 +52,7 @@ gen r _ c gc =
, lockContent = Nothing
, checkPresent = checkKey
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 2c4d24c35..4cc3c92e0 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -28,6 +28,7 @@ import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.Http
+import Remote.Helper.Export
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Creds
import Utility.Metered
@@ -40,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
@@ -68,6 +70,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , exportActions = exportUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
generated by cgit v1.2.3 (git 2.39.1) at 2024-08-19 06:30:42 +0000