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.

17 files changed, 166 insertions, 127 deletions

diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs
index 9a1be1c0e..37594bd11 100644
--- a/Remote/BitTorrent.hs
+++ b/Remote/BitTorrent.hs
@@ -36,12 +36,13 @@ import qualified Data.ByteString.Lazy as B
 #endif
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "bittorrent",
-	enumerate = list,
-	generate = gen,
-	setup = error "not supported"
-}
+remote = RemoteType
+	{ typename = "bittorrent"
+	, enumerate = list
+	, generate = gen
+	, setup = error "not supported"
+	, exportSupported = exportUnsupported
+	}
 
 -- There is only one bittorrent remote, and it always exists.
 list :: Bool -> Annex [Git.Repo]
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 6ff2aa885..4180cbb7d 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -35,12 +35,13 @@ import Utility.Metered
 type BupRepo = String
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "bup",
-	enumerate = const (findSpecialRemotes "buprepo"),
-	generate = gen,
-	setup = bupSetup
-}
+remote = RemoteType
+	{ typename = "bup"
+	, enumerate = const (findSpecialRemotes "buprepo")
+	, generate = gen
+	, setup = bupSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index c5d02a4e6..3949bf569 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -30,12 +30,13 @@ data DdarRepo = DdarRepo
 	}
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "ddar",
-	enumerate = const (findSpecialRemotes "ddarrepo"),
-	generate = gen,
-	setup = ddarSetup
-}
+remote = RemoteType
+	{ typename = "ddar"
+	, enumerate = const (findSpecialRemotes "ddarrepo")
+	, generate = gen
+	, setup = ddarSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 512ba1cef..22413b7e9 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -33,18 +33,19 @@ import Utility.Metered
 import Utility.Tmp
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "directory",
-	enumerate = const (findSpecialRemotes "directory"),
-	generate = gen,
-	setup = exportableRemoteSetup directorySetup
-}
+remote = RemoteType
+	{ typename = "directory"
+	, enumerate = const (findSpecialRemotes "directory")
+	, generate = gen
+	, 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
diff --git a/Remote/External.hs b/Remote/External.hs
index fca60a995..71a07d3ea 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -40,12 +40,13 @@ import System.Log.Logger (debugM)
 import qualified Data.Map as M
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "external",
-	enumerate = const (findSpecialRemotes "externaltype"),
-	generate = gen,
-	setup = externalSetup
-}
+remote = RemoteType
+	{ typename = "external"
+	, enumerate = const (findSpecialRemotes "externaltype")
+	, generate = gen
+	, setup = externalSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index dd681a75c..3270a1dc7 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -52,14 +52,15 @@ import Utility.Gpg
 import Utility.SshHost
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "gcrypt",
+remote = RemoteType
+	{ typename = "gcrypt"
 	-- Remote.Git takes care of enumerating gcrypt remotes too,
 	-- and will call our gen on them.
-	enumerate = const (return []),
-	generate = gen,
-	setup = gCryptSetup
-}
+	, enumerate = const (return [])
+	, generate = gen
+	, setup = gCryptSetup
+	, exportSupported = exportUnsupported
+	}
 
 chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 chainGen gcryptr u c gc = do
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 64fb51af8..02957fda2 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -67,12 +67,13 @@ import qualified Data.Map as M
 import Network.URI
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "git",
-	enumerate = list,
-	generate = gen,
-	setup = gitSetup
-}
+remote = RemoteType
+	{ typename = "git"
+	, enumerate = list
+	, generate = gen
+	, setup = gitSetup
+	, exportSupported = exportUnsupported
+	}
 
 list :: Bool -> Annex [Git.Repo]
 list autoinit = do
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 67e1b8b2e..40a92c700 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -30,12 +30,13 @@ type Vault = String
 type Archive = FilePath
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "glacier",
-	enumerate = const (findSpecialRemotes "glacier"),
-	generate = gen,
-	setup = glacierSetup
-}
+remote = RemoteType
+	{ typename = "glacier"
+	, enumerate = const (findSpecialRemotes "glacier")
+	, generate = gen
+	, setup = glacierSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index a46f7bd6c..58533155b 100644
--- a/Remote/Helper/Export.hs
+++ b/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
-exportUnsupported = ExportActions
-	{ exportSupported = return False
-	, storeExport = \_ _ _ _ -> return False
-	, retrieveExport = \_ _ _ _ -> return (False, UnVerified)
-	, removeExport = \_ _ -> return False
-	, checkPresentExport = \_ _ -> return False
-	, renameExport = \_ _ _ -> return False
-	}
+class HasExportUnsupported a where
+	exportUnsupported :: a
 
--- | A remote that supports exports when configured with exporttree=yes,
--- and otherwise does not.
-exportableRemote :: Remote -> Annex (Maybe Remote)
-exportableRemote r = case M.lookup "exporttree" (config r) of
-	Just "yes" -> do
-		db <- openDb (uuid r)
+instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
+	exportUnsupported = \_ _ -> return False
+
+instance HasExportUnsupported (ExportActions Annex) where
+	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
+			)
 
-		return $ Just $ r
+-- | 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
 			-- 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
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 5be4339e3..d7c7eb6b8 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -26,12 +26,13 @@ type Action = String
 type HookName = String
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "hook",
-	enumerate = const (findSpecialRemotes "hooktype"),
-	generate = gen,
-	setup = hookSetup
-}
+remote = RemoteType
+	{ typename = "hook"
+	, enumerate = const (findSpecialRemotes "hooktype")
+	, generate = gen
+	, setup = hookSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
diff --git a/Remote/List.hs b/Remote/List.hs
index a5e305622..2dc5e4823 100644
--- a/Remote/List.hs
+++ b/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
-	return $ adjustReadOnly . addHooks <$> mrmt
+	generate t r u c gc >>= maybe
+		(return Nothing)
+		(Just <$$> adjustExportable . adjustReadOnly . addHooks)
 
 {- Updates a local git Remote, re-reading its git config. -}
 updateRemote :: Remote -> Annex (Maybe Remote)
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
index f51b73b33..be0d4589f 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -34,14 +34,15 @@ import Control.Concurrent
 import Control.Concurrent.STM
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "p2p",
+remote = RemoteType
+	{ typename = "p2p"
 	-- Remote.Git takes care of enumerating P2P remotes,
 	-- and will call chainGen on them.
-	enumerate = const (return []),
-	generate = \_ _ _ _ -> return Nothing,
-	setup = error "P2P remotes are set up using git-annex p2p"
-}
+	, enumerate = const (return [])
+	, generate = \_ _ _ _ -> return Nothing
+	, 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
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 33485c78b..79aebad6b 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -44,12 +44,13 @@ import Utility.SshHost
 import qualified Data.Map as M
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "rsync",
-	enumerate = const (findSpecialRemotes "rsyncurl"),
-	generate = gen,
-	setup = rsyncSetup
-}
+remote = RemoteType
+	{ typename = "rsync"
+	, enumerate = const (findSpecialRemotes "rsyncurl")
+	, generate = gen
+	, setup = rsyncSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
diff --git a/Remote/S3.hs b/Remote/S3.hs
index ffa6a11bb..4b56cce29 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -54,12 +54,13 @@ import Utility.Url (checkBoth, managerSettings, closeManager)
 type BucketName = String
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "S3",
-	enumerate = const (findSpecialRemotes "s3"),
-	generate = gen,
-	setup = s3Setup
-}
+remote = RemoteType
+	{ typename = "S3"
+	, enumerate = const (findSpecialRemotes "s3")
+	, generate = gen
+	, setup = s3Setup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index b197edca2..d3d52d7de 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -52,12 +52,13 @@ type IntroducerFurl = String
 type Capability = String
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "tahoe",
-	enumerate = const (findSpecialRemotes "tahoe"),
-	generate = gen,
-	setup = tahoeSetup
-}
+remote = RemoteType
+	{ typename = "tahoe"
+	, enumerate = const (findSpecialRemotes "tahoe")
+	, generate = gen
+	, setup = tahoeSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 45e8d1c22..f3580ca99 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -23,12 +23,13 @@ import Annex.Quvi
 import qualified Utility.Quvi as Quvi
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "web",
-	enumerate = list,
-	generate = gen,
-	setup = error "not supported"
-}
+remote = RemoteType
+	{ typename = "web"
+	, enumerate = list
+	, generate = gen
+	, 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
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 4c9552a6f..4cc3c92e0 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -41,12 +41,13 @@ import Network.HTTP.Client (HttpExceptionContent(..), responseStatus)
 #endif
 
 remote :: RemoteType
-remote = RemoteType {
-	typename = "webdav",
-	enumerate = const (findSpecialRemotes "webdav"),
-	generate = gen,
-	setup = webdavSetup
-}
+remote = RemoteType
+	{ typename = "webdav"
+	, enumerate = const (findSpecialRemotes "webdav")
+	, generate = gen
+	, setup = webdavSetup
+	, exportSupported = exportUnsupported
+	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = new <$> remoteCost gc expensiveRemoteCost