mask remotes, partial implementation

Everything implemented except for passing through to the masked remote.
Which should be trivial.
This commit is contained in:
Joey Hess 2025-04-10 13:10:07 -04:00
parent 89fccc15a8
commit 1313cc4d60
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 218 additions and 1 deletions

View file

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

View file

@ -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.

205
Remote/Mask.hs Normal file
View file

@ -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"

View file

@ -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)

View file

@ -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.

View file

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