aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Remote/BitTorrent.hs5
-rw-r--r--Remote/Bup.hs5
-rw-r--r--Remote/Ddar.hs5
-rw-r--r--Remote/Directory.hs74
-rw-r--r--Remote/External.hs5
-rw-r--r--Remote/GCrypt.hs5
-rw-r--r--Remote/Git.hs5
-rw-r--r--Remote/Glacier.hs5
-rw-r--r--Remote/Hook.hs5
-rw-r--r--Remote/P2P.hs5
-rw-r--r--Remote/Rsync.hs5
-rw-r--r--Remote/S3.hs5
-rw-r--r--Remote/Tahoe.hs5
-rw-r--r--Remote/Web.hs5
-rw-r--r--Remote/WebDAV.hs5
-rw-r--r--Types/Remote.hs26
16 files changed, 158 insertions, 12 deletions
diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index 2f29f5baa..887a0898e 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -61,6 +61,11 @@ gen r _ c gc =
, lockContent = Nothing
, checkPresent = checkKey
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 3a2d67bc8..aad8e6bba 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -61,6 +61,11 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = bupLocal buprepo
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 2f8c3b345..1da3ff412 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -60,6 +60,11 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = ddarLocal ddarrepo
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 2452c42e2..a371a1951 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.
-}
@@ -58,6 +58,11 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = True
+ , storeExport = Just $ storeExportDirectory dir
+ , retrieveExport = Just $ retrieveExportDirectory dir
+ , removeExport = Just $ removeExportDirectory dir
+ , checkPresentExport = Just $ checkPresentExportDirectory dir
+ , renameExport = Just $ renameExportDirectory dir
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
@@ -119,16 +124,18 @@ 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
@@ -211,11 +218,56 @@ 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"
)
)
+
+exportPath :: FilePath -> ExportLocation -> FilePath
+exportPath d (ExportLocation loc) = d </> loc
+
+storeExportDirectory :: FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportDirectory d k loc p = sendAnnex k rollback send
+ where
+ dest = exportPath d loc
+ send src = liftIO $ catchBoolIO $ do
+ createDirectoryIfMissing True dest
+ withMeteredFile src p (L.writeFile dest)
+ return True
+ rollback = liftIO $ nukeFile dest
+
+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
+ void $ tryIO $ removeDirectory $ takeDirectory src
+ 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 dest
+ renameFile src dest
+ void $ tryIO $ removeDirectory $ takeDirectory src
+ return True
+ where
+ src = exportPath d oldloc
+ dest = exportPath d newloc
diff --git a/Remote/External.hs b/Remote/External.hs
index 32b95e9bb..dd62c1539 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -85,6 +85,11 @@ gen r u c gc
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = towhereis
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 2ccc47ad8..95b7ae287 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -114,6 +114,11 @@ gen' r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = repoCheap r
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Git.hs b/Remote/Git.hs
index b48b48b52..020cd1c61 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -157,6 +157,11 @@ gen r u c gc
, lockContent = Just (lockKey new)
, checkPresent = inAnnex new
, checkPresentCheap = repoCheap r
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = if Git.repoIsUrl r
then Nothing
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index c2f9bcf12..be65cecb7 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -57,6 +57,11 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 0ebbf9139..2a9874242 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -51,6 +51,11 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
index 118262b3c..d77ac89d8 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -57,6 +57,11 @@ chainGen addr r u c gc = do
, lockContent = Just (lock u addr connpool)
, checkPresent = checkpresent u addr connpool
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 4fc55d725..d40d23bae 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -73,6 +73,11 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/S3.hs b/Remote/S3.hs
index c05831b0b..ce6776595 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -84,6 +84,11 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Just (getWebUrls info)
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index e4686f2f2..cf65634b0 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -75,6 +75,11 @@ gen r u c gc = do
, lockContent = Nothing
, checkPresent = checkKey u hdl
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Just (getWhereisKey u)
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/Web.hs b/Remote/Web.hs
index be2f265e0..4d55389ec 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -50,6 +50,11 @@ gen r _ c gc =
, lockContent = Nothing
, checkPresent = checkKey
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 2c4d24c35..9230a027d 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -68,6 +68,11 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
, lockContent = Nothing
, checkPresent = checkPresentDummy
, checkPresentCheap = False
+ , storeExport = Nothing
+ , retrieveExport = Nothing
+ , removeExport = Nothing
+ , checkPresentExport = Nothing
+ , renameExport = Nothing
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
diff --git a/Types/Remote.hs b/Types/Remote.hs
index bd75840b3..d4b76f54f 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -2,7 +2,7 @@
-
- Most things should not need this, using Types instead
-
- - 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.
-}
@@ -18,6 +18,7 @@ module Types.Remote
, Availability(..)
, Verification(..)
, unVerified
+ , ExportLocation(..)
)
where
@@ -69,6 +70,7 @@ data RemoteA a = Remote {
name :: RemoteName,
-- Remotes have a use cost; higher is more expensive
cost :: Cost,
+
-- Transfers a key's contents from disk to the remote.
-- The key should not appear to be present on the remote until
-- all of its contents have been transferred.
@@ -94,6 +96,23 @@ data RemoteA a = Remote {
-- Some remotes can checkPresent without an expensive network
-- operation.
checkPresentCheap :: Bool,
+
+ -- Exports a key's contents to an ExportLocation.
+ -- The exported file does not need to be updated atomically.
+ storeExport :: Maybe (Key -> ExportLocation -> MeterUpdate -> a Bool),
+ -- Retrieves an exported key to a file.
+ -- (The MeterUpdate does not need to be used if it writes
+ -- sequentially to the file.)
+ retrieveExport :: Maybe (Key -> ExportLocation -> FilePath -> MeterUpdate -> a (Bool, Verification)),
+ -- Removes an exported key (succeeds if the contents are not present)
+ removeExport :: Maybe (Key -> ExportLocation -> a Bool),
+ -- Checks if a key is exported to the remote at the specified
+ -- ExportLocation.
+ -- Throws an exception if the remote cannot be accessed.
+ checkPresentExport :: Maybe (Key -> ExportLocation -> a Bool),
+ -- Renames an already exported key.
+ renameExport :: Maybe (Key -> ExportLocation -> ExportLocation -> a Bool),
+
-- Some remotes can provide additional details for whereis.
whereisKey :: Maybe (Key -> a [String]),
-- Some remotes can run a fsck operation on the remote,
@@ -150,3 +169,8 @@ unVerified :: Monad m => m Bool -> m (Bool, Verification)
unVerified a = do
ok <- a
return (ok, UnVerified)
+
+-- A location on a remote that a key can be exported to.
+-- The FilePath will be relative, and may contain unix-style path
+-- separators.
+newtype ExportLocation = ExportLocation FilePath
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 09:36:23 +0000