refactor ExportActions

This will allow disabling exports for remotes that are not configured to
allow them. Also, exportSupported will be useful for the external
special remote to probe.

This commit was supported by the NSF-funded DataLad project

Command/Export.hs

@@ -69,6 +69,9 @@ exportKey sha = mk <$> catKey sha
 seek :: ExportOptions -> CommandSeek
 seek o = do
 	r <- getParsed (exportRemote o)
+	unlessM (exportSupported (exportActions r)) $
+		error "That remote does not support exports."
+
 	new <- fromMaybe (error "unknown tree") <$>
 		-- Dereference the tree pointed to by the branch, commit,
 		-- or tag.
@@ -113,29 +116,28 @@ startExport r ti = do
 	f = getTopFilePath $ Git.LsTree.file ti
 
 performExport :: Remote -> ExportKey -> Sha -> ExportLocation -> CommandPerform
-performExport r ek contentsha loc = case storeExport r of
-	Nothing -> error "remote does not support exporting files"
-	Just storer -> do
-		sent <- case ek of
-			AnnexKey k -> ifM (inAnnex k)
-				( metered Nothing k $ \m -> do
-					let rollback = void $ performUnexport r ek loc
-					sendAnnex k rollback
-						(\f -> storer f k loc m)
-				, do
-					showNote "not available"
-					return False
-				)
-			-- Sending a non-annexed file.
-			GitKey sha1k -> metered Nothing sha1k $ \m ->
-				withTmpFile "export" $ \tmp h -> do
-					b <- catObject contentsha
-					liftIO $ L.hPut h b
-					liftIO $ hClose h
-					storer tmp sha1k loc m
-		if sent
-			then next $ cleanupExport r ek
-			else stop
+performExport r ek contentsha loc = do
+	let storer = storeExport $ exportActions r
+	sent <- case ek of
+		AnnexKey k -> ifM (inAnnex k)
+			( metered Nothing k $ \m -> do
+				let rollback = void $ performUnexport r ek loc
+				sendAnnex k rollback
+					(\f -> storer f k loc m)
+			, do
+				showNote "not available"
+				return False
+			)
+		-- Sending a non-annexed file.
+		GitKey sha1k -> metered Nothing sha1k $ \m ->
+			withTmpFile "export" $ \tmp h -> do
+				b <- catObject contentsha
+				liftIO $ L.hPut h b
+				liftIO $ hClose h
+				storer tmp sha1k loc m
+	if sent
+		then next $ cleanupExport r ek
+		else stop
 
 cleanupExport :: Remote -> ExportKey -> CommandCleanup
 cleanupExport r ek = do
@@ -154,13 +156,12 @@ startUnexport r diff
 	f = getTopFilePath $ Git.DiffTree.file diff
 
 performUnexport :: Remote -> ExportKey -> ExportLocation -> CommandPerform
-performUnexport r ek loc = case removeExport r of
-	Nothing -> error "remote does not support removing exported files"
-	Just remover -> do
-		ok <- remover (asKey ek) loc
-		if ok
-			then next $ cleanupUnexport r ek
-			else stop
+performUnexport r ek loc = do
+	let remover = removeExport $ exportActions r
+	ok <- remover (asKey ek) loc
+	if ok
+		then next $ cleanupUnexport r ek
+		else stop
 
 cleanupUnexport :: Remote -> ExportKey -> CommandCleanup
 cleanupUnexport r ek = do

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
 
@@ -61,11 +62,7 @@ gen r _ c gc =
 		, lockContent = Nothing
 		, checkPresent = checkKey
 		, checkPresentCheap = False
-		, storeExport = Nothing
-		, retrieveExport = Nothing
-		, removeExport = Nothing
-		, checkPresentExport = Nothing
-		, renameExport = Nothing
+		, exportActions = exportUnsupported
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
 		, repairRepo = Nothing

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
@@ -61,11 +62,7 @@ gen r u c gc = do
 		, lockContent = Nothing
 		, checkPresent = checkPresentDummy
 		, checkPresentCheap = bupLocal buprepo
-		, storeExport = Nothing
-		, retrieveExport = Nothing
-		, removeExport = Nothing
-		, checkPresentExport = Nothing
-		, renameExport = Nothing
+		, exportActions = exportUnsupported
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
 		, repairRepo = Nothing

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
@@ -60,11 +61,7 @@ gen r u c gc = do
 		, lockContent = Nothing
 		, checkPresent = checkPresentDummy
 		, checkPresentCheap = ddarLocal ddarrepo
-		, storeExport = Nothing
-		, retrieveExport = Nothing
-		, removeExport = Nothing
-		, checkPresentExport = Nothing
-		, renameExport = Nothing
+		, exportActions = exportUnsupported
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
 		, repairRepo = Nothing

Remote/Directory.hs

@@ -25,6 +25,7 @@ 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
@@ -59,11 +60,14 @@ 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
+			, exportActions = ExportActions
+				{ exportSupported = return True
+				, storeExport = storeExportDirectory dir
+				, retrieveExport = retrieveExportDirectory dir
+				, removeExport = removeExportDirectory dir
+				, checkPresentExport = checkPresentExportDirectory dir
+				, renameExport = renameExportDirectory dir
+				}
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
 			, repairRepo = Nothing

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
@@ -85,11 +86,7 @@ gen r u c gc
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, storeExport = Nothing
-			, retrieveExport = Nothing
-			, removeExport = Nothing
-			, checkPresentExport = Nothing
-			, renameExport = Nothing
+			, exportActions = exportUnsupported
 			, whereisKey = towhereis
 			, remoteFsck = Nothing
 			, repairRepo = Nothing

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
@@ -114,11 +115,7 @@ gen' r u c gc = do
 		, lockContent = Nothing
 		, checkPresent = checkPresentDummy
 		, checkPresentCheap = repoCheap r
-		, storeExport = Nothing
-		, retrieveExport = Nothing
-		, removeExport = Nothing
-		, checkPresentExport = Nothing
-		, renameExport = Nothing
+		, exportActions = exportUnsupported
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
 		, repairRepo = Nothing

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
@@ -157,11 +158,7 @@ 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
+			, exportActions = exportUnsupported
 			, whereisKey = Nothing
 			, remoteFsck = if Git.repoIsUrl r
 				then Nothing

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
@@ -57,11 +58,7 @@ 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
+			, exportActions = exportUnsupported
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
 			, repairRepo = Nothing

Remote/Helper/Export.hs

@@ -0,0 +1,21 @@
+{- exports to remotes
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Export where
+
+import Annex.Common
+import Types.Remote
+
+exportUnsupported :: ExportActions Annex
+exportUnsupported = ExportActions
+	{ exportSupported = return False
+	, storeExport = \_ _ _ _ -> return False
+	, retrieveExport = \_ _ _ _ -> return (False, UnVerified)
+	, removeExport = \_ _ -> return False
+	, checkPresentExport = \_ _ -> return False
+	, renameExport = \_ _ _ -> return False
+	}

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
 
@@ -51,11 +52,7 @@ gen r u c gc = do
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, storeExport = Nothing
-			, retrieveExport = Nothing
-			, removeExport = Nothing
-			, checkPresentExport = Nothing
-			, renameExport = Nothing
+			, exportActions = exportUnsupported
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
 			, repairRepo = Nothing

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
@@ -57,11 +58,7 @@ 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
+		, exportActions = exportUnsupported
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
 		, repairRepo = Nothing

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
@@ -73,11 +74,7 @@ gen r u c gc = do
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, storeExport = Nothing
-			, retrieveExport = Nothing
-			, removeExport = Nothing
-			, checkPresentExport = Nothing
-			, renameExport = Nothing
+			, exportActions = exportUnsupported
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
 			, repairRepo = Nothing

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
@@ -84,11 +85,7 @@ gen r u c gc = do
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, storeExport = Nothing
-			, retrieveExport = Nothing
-			, removeExport = Nothing
-			, checkPresentExport = Nothing
-			, renameExport = Nothing
+			, exportActions = exportUnsupported
 			, whereisKey = Just (getWebUrls info)
 			, remoteFsck = Nothing
 			, repairRepo = Nothing

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
@@ -75,11 +76,7 @@ gen r u c gc = do
 		, lockContent = Nothing
 		, checkPresent = checkKey u hdl
 		, checkPresentCheap = False
-		, storeExport = Nothing
-		, retrieveExport = Nothing
-		, removeExport = Nothing
-		, checkPresentExport = Nothing
-		, renameExport = Nothing
+		, exportActions = exportUnsupported
 		, whereisKey = Just (getWhereisKey u)
 		, remoteFsck = Nothing
 		, repairRepo = Nothing

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
@@ -50,11 +51,7 @@ gen r _ c gc =
 		, lockContent = Nothing
 		, checkPresent = checkKey
 		, checkPresentCheap = False
-		, storeExport = Nothing
-		, retrieveExport = Nothing
-		, removeExport = Nothing
-		, checkPresentExport = Nothing
-		, renameExport = Nothing
+		, exportActions = exportUnsupported
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
 		, repairRepo = Nothing

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
@@ -68,11 +69,7 @@ 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
+			, exportActions = exportUnsupported
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
 			, repairRepo = Nothing

Types/Remote.hs

@@ -19,6 +19,7 @@ module Types.Remote
 	, Verification(..)
 	, unVerified
 	, ExportLocation(..)
+	, ExportActions(..)
 	)
 	where
 
@@ -63,91 +64,75 @@ instance Eq (RemoteTypeA a) where
 	x == y = typename x == typename y
 
 {- An individual remote. -}
-data RemoteA a = Remote {
+data RemoteA a = Remote
 	-- each Remote has a unique uuid
-	uuid :: UUID,
+	{ uuid :: UUID
 	-- each Remote has a human visible name
-	name :: RemoteName,
+	, name :: RemoteName
 	-- Remotes have a use cost; higher is more expensive
-	cost :: Cost,
+	, 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.
-	storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool,
+	, storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool
 	-- Retrieves a key's contents to a file.
 	-- (The MeterUpdate does not need to be used if it writes
 	-- sequentially to the file.)
-	retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a (Bool, Verification),
+	, retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a (Bool, Verification)
 	-- Retrieves a key's contents to a tmp file, if it can be done cheaply.
 	-- It's ok to create a symlink or hardlink.
-	retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool,
+	, retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool
 	-- Removes a key's contents (succeeds if the contents are not present)
-	removeKey :: Key -> a Bool,
+	, removeKey :: Key -> a Bool
 	-- Uses locking to prevent removal of a key's contents,
 	-- thus producing a VerifiedCopy, which is passed to the callback.
 	-- If unable to lock, does not run the callback, and throws an
 	-- error.
 	-- This is optional; remotes do not have to support locking.
-	lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r),
+	, lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r)
 	-- Checks if a key is present in the remote.
 	-- Throws an exception if the remote cannot be accessed.
-	checkPresent :: Key -> a Bool,
+	, checkPresent :: Key -> a Bool
 	-- Some remotes can checkPresent without an expensive network
 	-- operation.
-	checkPresentCheap :: Bool,
-
-	-- Exports content to an ExportLocation.
-	-- The exported file should not appear to be present on the remote
-	-- until all of its contents have been transferred.
-	storeExport :: Maybe (FilePath -> Key -> ExportLocation -> MeterUpdate -> a Bool),
-	-- Retrieves exported content 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 file (succeeds if the contents are not present)
-	removeExport :: Maybe (Key -> ExportLocation -> a Bool),
-	-- Checks if anything 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 file.
-	renameExport :: Maybe (Key -> ExportLocation -> ExportLocation -> a Bool),
-
+	, checkPresentCheap :: Bool
+	-- Some remotes support exports of trees.
+	, exportActions :: ExportActions a
 	-- Some remotes can provide additional details for whereis.
-	whereisKey :: Maybe (Key -> a [String]),
+	, whereisKey :: Maybe (Key -> a [String])
 	-- Some remotes can run a fsck operation on the remote,
 	-- without transferring all the data to the local repo
 	-- The parameters are passed to the fsck command on the remote.
-	remoteFsck :: Maybe ([CommandParam] -> a (IO Bool)),
+	, remoteFsck :: Maybe ([CommandParam] -> a (IO Bool))
 	-- Runs an action to repair the remote's git repository.
-	repairRepo :: Maybe (a Bool -> a (IO Bool)),
+	, repairRepo :: Maybe (a Bool -> a (IO Bool))
 	-- a Remote has a persistent configuration store
-	config :: RemoteConfig,
+	, config :: RemoteConfig
 	-- git repo for the Remote
-	repo :: Git.Repo,
+	, repo :: Git.Repo
 	-- a Remote's configuration from git
-	gitconfig :: RemoteGitConfig,
+	, gitconfig :: RemoteGitConfig
 	-- a Remote can be assocated with a specific local filesystem path
-	localpath :: Maybe FilePath,
+	, localpath :: Maybe FilePath
 	-- a Remote can be known to be readonly
-	readonly :: Bool,
+	, readonly :: Bool
 	-- a Remote can be globally available. (Ie, "in the cloud".)
-	availability :: Availability,
+	, availability :: Availability
 	-- the type of the remote
-	remotetype :: RemoteTypeA a,
+	, remotetype :: RemoteTypeA a
 	-- For testing, makes a version of this remote that is not
 	-- available for use. All its actions should fail.
-	mkUnavailable :: a (Maybe (RemoteA a)),
+	, mkUnavailable :: a (Maybe (RemoteA a))
 	-- Information about the remote, for git annex info to display.
-	getInfo :: a [(String, String)],
+	, getInfo :: a [(String, String)]
 	-- Some remotes can download from an url (or uri).
-	claimUrl :: Maybe (URLString -> a Bool),
+	, claimUrl :: Maybe (URLString -> a Bool)
 	-- Checks that the url is accessible, and gets information about
 	-- its contents, without downloading the full content.
 	-- Throws an exception if the url is inaccessible.
-	checkUrl :: Maybe (URLString -> a UrlContents)
-}
+	, checkUrl :: Maybe (URLString -> a UrlContents)
+	}
 
 instance Show (RemoteA a) where
 	show remote = "Remote { name =\"" ++ name remote ++ "\" }"
@@ -175,3 +160,23 @@ unVerified a = do
 -- The FilePath will be relative, and may contain unix-style path
 -- separators.
 newtype ExportLocation = ExportLocation FilePath
+
+data ExportActions a = ExportActions
+	{ exportSupported :: a Bool
+	-- Exports content to an ExportLocation.
+	-- The exported file should not appear to be present on the remote
+	-- until all of its contents have been transferred.
+	, storeExport :: FilePath -> Key -> ExportLocation -> MeterUpdate -> a Bool
+	-- Retrieves exported content to a file.
+	-- (The MeterUpdate does not need to be used if it writes
+	-- sequentially to the file.)
+	, retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a (Bool, Verification)
+	-- Removes an exported file (succeeds if the contents are not present)
+	, removeExport :: Key -> ExportLocation -> a Bool
+	-- Checks if anything is exported to the remote at the specified
+	-- ExportLocation.
+	-- Throws an exception if the remote cannot be accessed.
+	, checkPresentExport :: Key -> ExportLocation -> a Bool
+	-- Renames an already exported file.
+	, renameExport :: Key -> ExportLocation -> ExportLocation -> a Bool
+	}

doc/design/exporting_trees_to_special_remotes.mdwn

@@ -83,6 +83,10 @@ the [[external_special_remote_protocol]].
 
 Here's the changes to the latter:
 
+* `EXPORTSUPPORTED`  
+  Used to check if a special remote supports exports. The remote
+  responds with either `EXPORTSUPPORTED-SUCCESS` or
+  `EXPORTSUPPORTED-FAILURE`
 * `EXPORT Name`  
   Comes immediately before each of the following requests, 
   specifying the name of the exported file. It will be in the form

git-annex.cabal

@@ -902,6 +902,7 @@ Executable git-annex
     Remote.Helper.Chunked
     Remote.Helper.Chunked.Legacy
     Remote.Helper.Encryptable
+    Remote.Helper.Export
     Remote.Helper.Git
     Remote.Helper.Hooks
     Remote.Helper.Http