add API for exporting

Implemented so far for the directory special remote.

Several remotes don't make sense to export to. Regular Git remotes,
obviously, do not. Bup remotes almost certianly do not, since bup would
need to be used to extract the export; same store for Ddar. Web and
Bittorrent are download-only. GCrypt is always encrypted so exporting to
it would be pointless. There's probably no point complicating the Hook
remotes with exporting at this point. External, S3, Glacier, WebDAV,
Rsync, and possibly Tahoe should be modified to support export.

Thought about trying to reuse the storeKey/retrieveKeyFile/removeKey
interface, rather than adding a new interface. But, it seemed better to
keep it separate, to avoid a complicated interface that sometimes
encrypts/chunks key/value storage and sometimes users non-key/value
storage. Any common parts can be factored out.

Note that storeExport is not atomic.
doc/design/exporting_trees_to_special_remotes.mdwn has some things in
the "resuming exports" section that bear on this decision. Basically,
I don't think, at this time, that an atomic storeExport would help with
resuming, because exports are not key/value storage, and we can't be
sure that a partially uploaded file is the same content we're currently
trying to export.

Also, note that ExportLocation will always use unix path separators.
This is important, because users may export from a mix of windows and
unix, and it avoids complicating the API with path conversions,
and ensures that in such a mix, they always use the same locations for
exports.

This commit was sponsored by Bruno BEAUFILS on Patreon.

15 files changed, 133 insertions, 11 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