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.

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

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

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

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,10 +124,12 @@ 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
+
+checkDiskSpaceDirectory :: FilePath -> Key -> Annex Bool
+checkDiskSpaceDirectory d k = do
 	annexdir <- fromRepo gitAnnexObjectDir
 	samefilesystem <- liftIO $ catchDefaultIO False $ 
 		(\a b -> deviceID a == deviceID b)
@@ -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

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

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

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

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

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

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

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

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

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

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

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

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