handle importtree=yes config

For now, it's only allowed when exporttree=yes is also set.
That simplified the implementation, but could later be changed if
there's a remote that makes sense to be an import but not an export.
However, it may work just as well to make a remote be readonly to
prevent export to it while still allowing import.

Annex/Import.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Annex.Import (
+	importTree,
 	ImportTreeConfig(..),
 	ImportCommitConfig(..),
 	buildImportCommit,
@@ -30,6 +31,7 @@ import Annex.LockFile
 import Annex.Content
 import Annex.Export
 import Backend
+import Config
 import Types.Key
 import Types.KeySource
 import Utility.Metered
@@ -43,6 +45,9 @@ import qualified Database.ContentIdentifier as CID
 import Control.Concurrent.STM
 import qualified Data.Map.Strict as M
 
+importTree :: Remote.RemoteConfig -> Bool
+importTree c = fromMaybe False $ yesNo =<< M.lookup "importtree" c
+
 {- Configures how to build an import tree. -}
 data ImportTreeConfig
 	= ImportTree

Command/Import.hs

@@ -245,6 +245,8 @@ verifyExisting key destfile (yes, no) = do
 
 seekRemote :: Remote -> Branch -> Maybe TopFilePath -> CommandSeek
 seekRemote remote branch msubdir = allowConcurrentOutput $ do
+	unlessM (Remote.isImportSupported remote) $
+		giveup "That remote does not support imports."
 	importtreeconfig <- case msubdir of
 		Nothing -> return ImportTree
 		Just subdir ->

Remote/Directory.hs

@@ -42,7 +42,7 @@ remote = RemoteType
 	, generate = gen
 	, setup = directorySetup
 	, exportSupported = exportIsSupported
-	, importSupported = importUnsupported
+	, importSupported = importIsSupported
 	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)

Remote/Helper/ExportImport.hs

@@ -17,6 +17,7 @@ import Backend
 import Remote.Helper.Encryptable (isEncrypted)
 import Database.Export
 import Annex.Export
+import Annex.Import
 import Config
 import Git.Types (fromRef)
 import Logs.Export
@@ -60,27 +61,57 @@ instance HasImportUnsupported (ImportActions Annex) where
 exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
 exportIsSupported = \_ _ -> return True
 
--- | Prevent or allow exporttree=yes when setting up a new remote,
+importIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
--- depending on exportSupported and other configuration.
+importIsSupported = \_ _ -> return True
-adjustExportableRemoteType :: RemoteType -> RemoteType
+
-adjustExportableRemoteType rt = rt { setup = setup' }
+-- | Prevent or allow exporttree=yes and importtree=yes when
+-- setting up a new remote, depending on exportSupported and importSupported.
+adjustExportImportRemoteType :: RemoteType -> RemoteType
+adjustExportImportRemoteType rt = rt { setup = setup' }
   where
-	setup' st mu cp c gc = do
+	setup' st mu cp c gc =
-		let cont = setup rt st mu cp c gc
+		let checkconfig supported configured setting cont =
-		ifM (exportSupported rt c gc)
+			ifM (supported rt c gc)
 				( case st of
 					Init
-					| exportTree c && isEncrypted c ->
+						| configured c && isEncrypted c ->
-						giveup "cannot enable both encryption and exporttree"
+							giveup $ "cannot enable both encryption and " ++ setting
 						| otherwise -> cont
 					Enable oldc
-					| exportTree c /= exportTree oldc ->
+						| configured c /= configured oldc ->
-						giveup "cannot change exporttree of existing special remote"
+							giveup $ "cannot change " ++ setting ++ " of existing special remote"
 						| otherwise -> cont
-			, if exportTree c
+				, if configured c
-				then giveup "exporttree=yes is not supported by this special remote"
+					then giveup $ setting ++ " is not supported by this special remote"
 					else cont
 				)
+		in checkconfig exportSupported exportTree "exporttree" $
+			checkconfig importSupported importTree "importtree" $
+				if importTree c && not (exportTree c)
+					then giveup "cannot enable importtree=yes without also enabling exporttree=yes"
+					else setup rt st mu cp c gc
+
+-- | If the remote is importSupported, and importtree=yes, adjust the
+-- remote to be an import.
+--
+-- (This relies on all import remotes also being export remotes,
+-- so adjustExportable will adjust the remote actions to use the
+-- exported/imported tree.)
+adjustImportable :: Remote -> Annex Remote
+adjustImportable r
+	| importTree (config r) =
+		ifM (isExportSupported r)
+			( return r
+			, notimport
+			)
+	| otherwise = notimport
+  where
+	notimport = return $ r 
+		{ importActions = importUnsupported
+		, remotetype = (remotetype r)
+			{ importSupported = importUnsupported
+			}
+		}
 
 -- | If the remote is exportSupported, and exporttree=yes, adjust the
 -- remote to be an export.

Remote/List.hs

@@ -44,7 +44,7 @@ import qualified Remote.Hook
 import qualified Remote.External
 
 remoteTypes :: [RemoteType]
-remoteTypes = map adjustExportableRemoteType
+remoteTypes = map adjustExportImportRemoteType
 	[ Remote.Git.remote
 	, Remote.GCrypt.remote
 	, Remote.P2P.remote
@@ -100,13 +100,16 @@ remoteListRefresh = do
 
 {- Generates a Remote. -}
 remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe Remote)
-remoteGen m t r = do
+remoteGen m t g = do
-	u <- getRepoUUID r
+	u <- getRepoUUID g
-	gc <- Annex.getRemoteGitConfig r
+	gc <- Annex.getRemoteGitConfig g
 	let c = fromMaybe M.empty $ M.lookup u m
-	generate t r u c gc >>= maybe
+	generate t g u c gc >>= \case
-		(return Nothing)
+		Nothing -> return Nothing
-		(Just <$$> adjustExportable . adjustReadOnly . addHooks)
+		Just r -> do
+			r' <- adjustImportable (adjustReadOnly (addHooks r))
+			r'' <- adjustExportable r'
+			return $ Just r''
 
 {- Updates a local git Remote, re-reading its git config. -}
 updateRemote :: Remote -> Annex (Maybe Remote)

Types/Remote.hs

@@ -20,6 +20,7 @@ module Types.Remote
 	, unVerified
 	, RetrievalSecurityPolicy(..)
 	, isExportSupported
+	, isImportSupported
 	, ExportActions(..)
 	, ImportActions(..)
 	, ByteSize
@@ -215,6 +216,9 @@ data RetrievalSecurityPolicy
 isExportSupported :: RemoteA a -> a Bool
 isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r)
 
+isImportSupported :: RemoteA a -> a Bool
+isImportSupported r = importSupported (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

doc/todo/import_tree.mdwn

@@ -13,8 +13,6 @@ this.
 * Need to support annex-tracking-branch configuration, which documentation
   says makes git-annex sync and assistant do imports.
 
-* need to check if a remote has importtree=yes before trying to import from it
-
 * export needs to use storeExportWithContentIdentifierM for importtree=yes
   remotes