mask remotes, partial implementation

Everything implemented except for passing through to the masked remote.
Which should be trivial.

Remote/Helper/Encryptable.hs

@@ -8,7 +8,7 @@
 {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, PackageImports #-}
 
 module Remote.Helper.Encryptable (
-	EncryptionIsSetup,
+	EncryptionIsSetup(..),
 	encryptionSetup,
 	noEncryptionUsed,
 	encryptionAlreadySetup,

Remote/List.hs

@@ -41,6 +41,7 @@ import qualified Remote.Rclone
 import qualified Remote.Hook
 import qualified Remote.External
 import qualified Remote.Compute
+import qualified Remote.Mask
 
 remoteTypes :: [RemoteType]
 remoteTypes = map adjustExportImportRemoteType
@@ -65,6 +66,7 @@ remoteTypes = map adjustExportImportRemoteType
 	, Remote.Hook.remote
 	, Remote.External.remote
 	, Remote.Compute.remote
+	, Remote.Mask.remote
 	]
 
 {- Builds a list of all Remotes.

Remote/Mask.hs

@@ -0,0 +1,205 @@
+{- Mask another remote with added encryption
+ -
+ - Copyright 2025 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE RankNTypes #-}
+
+module Remote.Mask (remote) where
+
+import Annex.Common
+import Types.Remote
+import Types.Creds
+import Types.Crypto
+import qualified Git
+import qualified Annex
+import Remote.Helper.Special
+import Remote.Helper.ExportImport
+import Config
+import Config.Cost
+import Annex.UUID
+import Types.ProposedAccepted
+import Annex.SpecialRemote.Config
+import Logs.UUID
+import qualified Remote.Git
+
+import qualified Data.Map as M
+
+remote :: RemoteType
+remote = specialRemoteType $ RemoteType
+	{ typename = "mask"
+	, enumerate = const (findSpecialRemotes "mask")
+	, generate = gen
+	, configParser = mkRemoteConfigParser
+		[ optionalStringParser remoteField
+			(FieldDesc "remote to mask")
+		]
+	, setup = maskSetup
+	, exportSupported = exportIsSupported
+	, importSupported = importIsSupported
+	, thirdPartyPopulated = False
+	}
+
+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+gen r u rc gc rs = do
+	maskedremote <- getMaskedRemote rc gc
+	let inherited d f = case maskedremote of
+		Right mr -> f mr
+		Left _ -> d
+	c <- parsedRemoteConfig remote rc
+	cst <- remoteCost gc c $ encryptedRemoteCostAdj + 
+		inherited semiExpensiveRemoteCost cost
+	let this = Remote
+		{ uuid = u
+		, cost = cst
+		, name = Git.repoDescribe r
+		, storeKey = storeKeyDummy
+		, retrieveKeyFile = retrieveKeyFileDummy
+		, retrieveKeyFileInOrder = pure True
+		, retrieveKeyFileCheap = Nothing
+		, retrievalSecurityPolicy = inherited RetrievalVerifiableKeysSecure retrievalSecurityPolicy
+		, removeKey = removeKeyDummy
+		, lockContent = Nothing
+		, checkPresent = checkPresentDummy
+		, checkPresentCheap = inherited False checkPresentCheap
+		, exportActions = exportUnsupported
+		, importActions = importUnsupported
+		, whereisKey = Nothing
+		, remoteFsck = Nothing
+		, repairRepo = Nothing
+		, config = c
+		, getRepo = return r
+		, gitconfig = gc
+		, localpath = Nothing
+		, remotetype = remote
+		, availability = inherited (pure Unavailable) availability
+		, readonly = inherited False readonly
+		, appendonly = inherited False appendonly
+		, untrustworthy = inherited False untrustworthy
+		, mkUnavailable = return Nothing
+		, getInfo = inherited (pure []) getInfo
+		, claimUrl = Nothing
+		, checkUrl = Nothing
+		, remoteStateHandle = rs
+		}
+	return $ Just $ specialRemote c
+		(store maskedremote)
+		(retrieve maskedremote)
+		(remove maskedremote)
+		(checkKey maskedremote)
+		this
+
+maskSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+maskSetup setupstage mu _ c gc = do
+	remotelist <- Annex.getState Annex.remotes
+	let findnamed maskremotename =
+		case filter (\r -> name r == maskremotename) remotelist of
+			(r:_) -> return r
+			[] -> giveup $ "There is no remote named \"" ++ maskremotename ++ "\""
+	case setupstage of
+		Init -> do
+			maskremotename <- maybe
+				(giveup "Specify remote=")
+				(pure . fromProposedAccepted)
+				(M.lookup remoteField c)
+			setupremote =<< findnamed maskremotename
+		_ -> case M.lookup remoteField c of
+			Just (Proposed maskremotename) ->
+				setupremote =<< findnamed maskremotename
+			_ -> enableremote remotelist
+  where
+	setupremote r = do
+		let c' = M.insert remoteUUIDField
+			(Proposed (fromUUID (uuid r) :: String)) c
+		(c'', encsetup) <- encryptionSetup c' gc
+		verifyencryptionok encsetup r
+		
+		u <- maybe (liftIO genUUID) return mu
+		gitConfigSpecialRemote u c'' [ ("mask", name r) ]
+		return (c'', u)
+				
+	enableremote remotelist = do
+		let maskremoteuuid = fromMaybe NoUUID $ 
+			toUUID . fromProposedAccepted
+				<$> M.lookup remoteUUIDField c
+		case filter (\r -> uuid r == maskremoteuuid) remotelist of
+			(r:_) -> setupremote r
+			[] -> case setupstage of
+				Enable _ ->
+					missingMaskedRemote maskremoteuuid
+				-- When autoenabling, the masked remote may
+				-- get autoenabled later.
+				_ -> do
+					(c', _) <- encryptionSetup c gc
+					u <- maybe (liftIO genUUID) return mu
+					gitConfigSpecialRemote u c' [ ("mask", "true") ]
+					return (c', u)
+
+	verifyencryptionok NoEncryption _ =
+		giveup "Must use encryption with a mask special remote."
+	verifyencryptionok EncryptionIsSetup r
+		| remotetype r == Remote.Git.remote =
+			verifyencryptionokgit
+		| otherwise = noop
+	
+	verifyencryptionokgit = case parseEncryptionMethod c of
+		Right SharedEncryption ->
+			giveup "It's not secure to use encryption=shared with a git remote."
+		_ -> noop
+
+getMaskedRemote :: RemoteConfig -> RemoteGitConfig -> Annex (Either UUID Remote)
+getMaskedRemote c gc = case remoteAnnexMask gc of
+	-- This remote was autoenabled, so use any remote with the
+	-- uuid of the masked remote, so that it can also be autoenabled.
+	Just "true" -> 
+		case getmaskedremoteuuid of
+			Just maskremoteuuid -> 
+				selectremote (\r -> uuid r == maskremoteuuid)
+					maskremoteuuid
+			Nothing -> return (Left NoUUID)
+	Just maskremotename ->
+		selectremote (\r -> name r == maskremotename) $
+			(fromMaybe NoUUID getmaskedremoteuuid)
+	Nothing -> return (Left NoUUID)
+  where
+	getmaskedremoteuuid = toUUID . fromProposedAccepted <$> M.lookup remoteField c
+	selectremote f fallback = do
+		remotelist <- Annex.getState Annex.remotes
+		case filter f remotelist of
+			(r:_) -> return (Right r)
+			[] -> return (Left fallback)
+
+missingMaskedRemote :: UUID -> Annex a
+missingMaskedRemote maskremoteuuid = do
+	descmap <- uuidDescMap
+	let desc = case M.lookup maskremoteuuid descmap of
+		Just (UUIDDesc d) -> decodeBS d
+		Nothing -> ""
+	giveup $ unlines
+		[ "Before this mask special remote can be used, you must set up the remote it uses:"
+		, "  " ++ fromUUID maskremoteuuid ++ " -- " ++ desc
+		]
+
+store :: Either UUID Remote -> Storer
+store (Right maskedremote) k src p = undefined
+store (Left maskedremoteuuid) _ _ _ = missingMaskedRemote maskedremoteuuid
+
+retrieve :: Either UUID Remote -> Retriever
+retrieve (Right maskedremote) k p dest iv callback = undefined
+retrieve (Left maskedremoteuuid) _ _ _ _ _ = missingMaskedRemote maskedremoteuuid
+
+remove :: Either UUID Remote -> Remover
+remove (Right maskedremote) proof k = undefined
+remove (Left maskedremoteuuid) _ _ = missingMaskedRemote maskedremoteuuid
+
+checkKey :: Either UUID Remote -> CheckPresent
+checkKey (Right maskedremote) k = undefined
+checkKey (Left maskedremoteuuid) _ = missingMaskedRemote maskedremoteuuid
+
+remoteField :: RemoteConfigField
+remoteField = Accepted "remote"
+
+remoteUUIDField :: RemoteConfigField
+remoteUUIDField = Accepted "remoteuuid"

Types/GitConfig.hs

@@ -441,6 +441,7 @@ data RemoteGitConfig = RemoteGitConfig
 	, remoteAnnexDdarRepo :: Maybe String
 	, remoteAnnexHookType :: Maybe String
 	, remoteAnnexExternalType :: Maybe String
+	, remoteAnnexMask :: Maybe String
 	}
 
 {- The Git.Repo is the local repository, which has the remote with the
@@ -541,6 +542,7 @@ extractRemoteGitConfig r remotename = do
 		, remoteAnnexDdarRepo = getmaybe DdarRepoField
 		, remoteAnnexHookType = notempty $ getmaybe HookTypeField
 		, remoteAnnexExternalType = notempty $ getmaybe ExternalTypeField
+		, remoteAnnexMask = notempty $ getmaybe MaskField
 		}
   where
 	getbool k d = fromMaybe d $ getmaybebool k
@@ -623,6 +625,7 @@ data RemoteGitConfigField
 	| DdarRepoField
 	| HookTypeField
 	| ExternalTypeField
+	| MaskField
 	deriving (Enum, Bounded)
 
 remoteGitConfigField :: RemoteGitConfigField -> (MkRemoteConfigKey, ProxyInherited)
@@ -693,6 +696,7 @@ remoteGitConfigField = \case
 	DdarRepoField -> uninherited True "ddarrepo"
 	HookTypeField -> uninherited True "hooktype"
 	ExternalTypeField -> uninherited True "externaltype"
+	MaskField -> uninherited True "mask"
   where
 	inherited True f = (MkRemoteAnnexConfigKey f, ProxyInherited True)
 	inherited False f = (MkRemoteConfigKey f, ProxyInherited True)

doc/git-annex.mdwn

@@ -2051,6 +2051,11 @@ Remotes are configured using these settings in `.git/config`.
   Used to identify httpalso special remotes.
   Normally this is automatically set up by `git annex initremote`.
 
+* `remote.<name>.annex-mask`
+
+  Used by mask special remotes.
+  Normally this is automatically set up by `git annex initremote`.
+
 * `remote.<name>.annex-externaltype`
 
   Used by external special remotes to record the type of the remote.

git-annex.cabal

@@ -964,6 +964,7 @@ Executable git-annex
     Remote.Hook
     Remote.List
     Remote.List.Util
+    Remote.Mask
     Remote.P2P
     Remote.Rclone
     Remote.Rsync