prevent exporttree=yes on remotes that don't support exports

Don't allow "exporttree=yes" to be set when the special remote
does not support exports. That would be confusing since the user would
set up a special remote for exports, but `git annex export` to it would
later fail.

This commit was supported by the NSF-funded DataLad project.

Annex/Content.hs

@@ -359,7 +359,7 @@ shouldVerify (RemoteVerify r) =
 			<&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r)))
 	-- Export remotes are not key/value stores, so always verify
 	-- content from them even when verification is disabled.
-	<||> Types.Remote.exportSupported (Types.Remote.exportActions r)
+	<||> Types.Remote.isExportSupported r
 
 {- Checks if there is enough free disk space to download a key
  - to its temp file.

Command/Export.hs

@@ -77,7 +77,7 @@ exportTempName ek = ExportLocation $
 seek :: ExportOptions -> CommandSeek
 seek o = do
 	r <- getParsed (exportRemote o)
-	unlessM (exportSupported (exportActions r)) $
+	unlessM (isExportSupported r) $
 		giveup "That remote does not support exports."
 
 	new <- fromMaybe (giveup "unknown tree") <$>

Logs/Trust.hs

@@ -67,7 +67,7 @@ trustMapLoad = do
 	overrides <- Annex.getState Annex.forcetrust
 	l <- remoteList
 	-- Exports are never trusted, since they are not key/value stores.
-	exports <- filterM (Types.Remote.exportSupported . Types.Remote.exportActions) l
+	exports <- filterM Types.Remote.isExportSupported l
 	let exportoverrides = M.fromList $
 		map (\r -> (Types.Remote.uuid r, UnTrusted)) exports
 	logged <- trustMapRaw

Remote.hs

@@ -53,6 +53,7 @@ module Remote (
 	checkAvailable,
 	isXMPPRemote,
 	claimingUrl,
+	isExportSupported,
 ) where
 
 import Data.Ord

Remote/BitTorrent.hs

@@ -36,12 +36,13 @@ import qualified Data.ByteString.Lazy as B
 #endif
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "bittorrent",
+	{ typename = "bittorrent"
-	enumerate = list,
+	, enumerate = list
-	generate = gen,
+	, generate = gen
-	setup = error "not supported"
+	, setup = error "not supported"
-}
+	, exportSupported = exportUnsupported
+	}
 
 -- There is only one bittorrent remote, and it always exists.
 list :: Bool -> Annex [Git.Repo]

Remote/Bup.hs

@@ -35,12 +35,13 @@ import Utility.Metered
 type BupRepo = String
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "bup",
+	{ typename = "bup"
-	enumerate = const (findSpecialRemotes "buprepo"),
+	, enumerate = const (findSpecialRemotes "buprepo")
-	generate = gen,
+	, generate = gen
-	setup = bupSetup
+	, setup = bupSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do

Remote/Ddar.hs

@@ -30,12 +30,13 @@ data DdarRepo = DdarRepo
 	}
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "ddar",
+	{ typename = "ddar"
-	enumerate = const (findSpecialRemotes "ddarrepo"),
+	, enumerate = const (findSpecialRemotes "ddarrepo")
-	generate = gen,
+	, generate = gen
-	setup = ddarSetup
+	, setup = ddarSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do

Remote/Directory.hs

@@ -33,18 +33,19 @@ import Utility.Metered
 import Utility.Tmp
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "directory",
+	{ typename = "directory"
-	enumerate = const (findSpecialRemotes "directory"),
+	, enumerate = const (findSpecialRemotes "directory")
-	generate = gen,
+	, generate = gen
-	setup = exportableRemoteSetup directorySetup
+	, setup = directorySetup
-}
+	, exportSupported = exportIsSupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
 	cst <- remoteCost gc cheapRemoteCost
 	let chunkconfig = getChunkConfig c
-	exportableRemote $ specialRemote c
+	return $ Just $ specialRemote c
 		(prepareStore dir chunkconfig)
 		(retrieve dir chunkconfig)
 		(simplyPrepare $ remove dir)
@@ -61,8 +62,7 @@ gen r u c gc = do
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = True
 			, exportActions = ExportActions
-				{ exportSupported = return True
+				{ storeExport = storeExportDirectory dir
-				, storeExport = storeExportDirectory dir
 				, retrieveExport = retrieveExportDirectory dir
 				, removeExport = removeExportDirectory dir
 				, checkPresentExport = checkPresentExportDirectory dir

Remote/External.hs

@@ -40,12 +40,13 @@ import System.Log.Logger (debugM)
 import qualified Data.Map as M
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "external",
+	{ typename = "external"
-	enumerate = const (findSpecialRemotes "externaltype"),
+	, enumerate = const (findSpecialRemotes "externaltype")
-	generate = gen,
+	, generate = gen
-	setup = externalSetup
+	, setup = externalSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc

Remote/GCrypt.hs

@@ -52,14 +52,15 @@ import Utility.Gpg
 import Utility.SshHost
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "gcrypt",
+	{ typename = "gcrypt"
 	-- Remote.Git takes care of enumerating gcrypt remotes too,
 	-- and will call our gen on them.
-	enumerate = const (return []),
+	, enumerate = const (return [])
-	generate = gen,
+	, generate = gen
-	setup = gCryptSetup
+	, setup = gCryptSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 chainGen gcryptr u c gc = do

Remote/Git.hs

@@ -67,12 +67,13 @@ import qualified Data.Map as M
 import Network.URI
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "git",
+	{ typename = "git"
-	enumerate = list,
+	, enumerate = list
-	generate = gen,
+	, generate = gen
-	setup = gitSetup
+	, setup = gitSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 list :: Bool -> Annex [Git.Repo]
 list autoinit = do

Remote/Glacier.hs

@@ -30,12 +30,13 @@ type Vault = String
 type Archive = FilePath
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "glacier",
+	{ typename = "glacier"
-	enumerate = const (findSpecialRemotes "glacier"),
+	, enumerate = const (findSpecialRemotes "glacier")
-	generate = gen,
+	, generate = gen
-	setup = glacierSetup
+	, setup = glacierSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost

Remote/Helper/Export.hs

@@ -5,11 +5,12 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE FlexibleInstances #-}
+
 module Remote.Helper.Export where
 
 import Annex.Common
 import Types.Remote
-import Types.Creds
 import Types.Backend
 import Types.Key
 import Backend
@@ -19,24 +20,60 @@ import Database.Export
 import qualified Data.Map as M
 
 -- | Use for remotes that do not support exports.
-exportUnsupported :: ExportActions Annex
+class HasExportUnsupported a where
-exportUnsupported = ExportActions
+	exportUnsupported :: a
-	{ exportSupported = return False
-	, storeExport = \_ _ _ _ -> return False
-	, retrieveExport = \_ _ _ _ -> return (False, UnVerified)
-	, removeExport = \_ _ -> return False
-	, checkPresentExport = \_ _ -> return False
-	, renameExport = \_ _ _ -> return False
-	}
 
--- | A remote that supports exports when configured with exporttree=yes,
+instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
--- and otherwise does not.
+	exportUnsupported = \_ _ -> return False
-exportableRemote :: Remote -> Annex (Maybe Remote)
+
-exportableRemote r = case M.lookup "exporttree" (config r) of
+instance HasExportUnsupported (ExportActions Annex) where
-	Just "yes" -> do
+	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
-		return $ Just $ 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
@@ -87,17 +124,3 @@ exportableRemote r = case M.lookup "exporttree" (config r) of
 				is <- getInfo r
 				return (is++[("export", "yes")])
 			}
-	_ -> return $ Just $ r { exportActions = exportUnsupported }
-
-exportableRemoteSetup :: (SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)) -> SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-exportableRemoteSetup setupaction st mu cp 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
-  where
-	cont = setupaction st mu cp c gc

Remote/Hook.hs

@@ -26,12 +26,13 @@ type Action = String
 type HookName = String
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "hook",
+	{ typename = "hook"
-	enumerate = const (findSpecialRemotes "hooktype"),
+	, enumerate = const (findSpecialRemotes "hooktype")
-	generate = gen,
+	, generate = gen
-	setup = hookSetup
+	, setup = hookSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do

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
+	generate t r u c gc >>= maybe
-	return $ adjustReadOnly . addHooks <$> mrmt
+		(return Nothing)
+		(Just <$$> adjustExportable . adjustReadOnly . addHooks)
 
 {- Updates a local git Remote, re-reading its git config. -}
 updateRemote :: Remote -> Annex (Maybe Remote)

Remote/P2P.hs

@@ -34,14 +34,15 @@ import Control.Concurrent
 import Control.Concurrent.STM
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "p2p",
+	{ typename = "p2p"
 	-- Remote.Git takes care of enumerating P2P remotes,
 	-- and will call chainGen on them.
-	enumerate = const (return []),
+	, enumerate = const (return [])
-	generate = \_ _ _ _ -> return Nothing,
+	, generate = \_ _ _ _ -> return Nothing
-	setup = error "P2P remotes are set up using git-annex p2p"
+	, 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

Remote/Rsync.hs

@@ -44,12 +44,13 @@ import Utility.SshHost
 import qualified Data.Map as M
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "rsync",
+	{ typename = "rsync"
-	enumerate = const (findSpecialRemotes "rsyncurl"),
+	, enumerate = const (findSpecialRemotes "rsyncurl")
-	generate = gen,
+	, generate = gen
-	setup = rsyncSetup
+	, setup = rsyncSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do

Remote/S3.hs

@@ -54,12 +54,13 @@ import Utility.Url (checkBoth, managerSettings, closeManager)
 type BucketName = String
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "S3",
+	{ typename = "S3"
-	enumerate = const (findSpecialRemotes "s3"),
+	, enumerate = const (findSpecialRemotes "s3")
-	generate = gen,
+	, generate = gen
-	setup = s3Setup
+	, setup = s3Setup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do

Remote/Tahoe.hs

@@ -52,12 +52,13 @@ type IntroducerFurl = String
 type Capability = String
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "tahoe",
+	{ typename = "tahoe"
-	enumerate = const (findSpecialRemotes "tahoe"),
+	, enumerate = const (findSpecialRemotes "tahoe")
-	generate = gen,
+	, generate = gen
-	setup = tahoeSetup
+	, setup = tahoeSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do

Remote/Web.hs

@@ -23,12 +23,13 @@ import Annex.Quvi
 import qualified Utility.Quvi as Quvi
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "web",
+	{ typename = "web"
-	enumerate = list,
+	, enumerate = list
-	generate = gen,
+	, generate = gen
-	setup = error "not supported"
+	, 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

Remote/WebDAV.hs

@@ -41,12 +41,13 @@ import Network.HTTP.Client (HttpExceptionContent(..), responseStatus)
 #endif
 
 remote :: RemoteType
-remote = RemoteType {
+remote = RemoteType
-	typename = "webdav",
+	{ typename = "webdav"
-	enumerate = const (findSpecialRemotes "webdav"),
+	, enumerate = const (findSpecialRemotes "webdav")
-	generate = gen,
+	, generate = gen
-	setup = webdavSetup
+	, setup = webdavSetup
-}
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = new <$> remoteCost gc expensiveRemoteCost

Types/Remote.hs

@@ -19,6 +19,7 @@ module Types.Remote
 	, Verification(..)
 	, unVerified
 	, ExportLocation(..)
+	, isExportSupported
 	, ExportActions(..)
 	)
 	where
@@ -36,7 +37,7 @@ import Types.UrlContents
 import Types.NumCopies
 import Config.Cost
 import Utility.Metered
-import Git.Types
+import Git.Types (RemoteName)
 import Utility.SafeCommand
 import Utility.Url
 
@@ -47,17 +48,19 @@ type RemoteConfig = M.Map RemoteConfigKey String
 data SetupStage = Init | Enable RemoteConfig
 
 {- There are different types of remotes. -}
-data RemoteTypeA a = RemoteType {
+data RemoteTypeA a = RemoteType
 	-- human visible type name
-	typename :: String,
+	{ typename :: String
 	-- enumerates remotes of this type
 	-- The Bool is True if automatic initialization of remotes is desired
-	enumerate :: Bool -> a [Git.Repo],
+	, enumerate :: Bool -> a [Git.Repo]
-	-- generates a remote of this type
+	-- generates a remote of this type from the current git config
-	generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
+	, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a))
 	-- initializes or enables a remote
-	setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
+	, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
-}
+	-- check if a remote of this type is able to support export
+	, exportSupported :: RemoteConfig -> RemoteGitConfig -> a Bool
+	}
 
 instance Eq (RemoteTypeA a) where
 	x == y = typename x == typename y
@@ -161,12 +164,14 @@ unVerified a = do
 newtype ExportLocation = ExportLocation FilePath
 	deriving (Show, Eq)
 
-data ExportActions a = ExportActions
+isExportSupported :: RemoteA a -> a Bool
-	{ exportSupported :: a Bool
+isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r)
+
+data ExportActions a = ExportActions 
 	-- 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
+	{ 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.)

doc/todo/export.mdwn

@@ -17,10 +17,6 @@ there need to be a new interface in supported remotes?
 
 Work is in progress. Todo list:
 
-* initremote: Don't allow "exporttree=yes" to be set when the special remote
-  does not support exports. That would be confusing since the user would
-  set up a special remote for exports, but `git annex export` to it would
-  later fail..
 * `git annex get --from export` works in the repo that exported to it,
   but in another repo, the export db won't be populated, so it won't work.
   Maybe just show a useful error message in this case?