diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 9f4bd7fcb1..33eb5b3837 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -8,7 +8,7 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, PackageImports #-} module Remote.Helper.Encryptable ( - EncryptionIsSetup, + EncryptionIsSetup(..), encryptionSetup, noEncryptionUsed, encryptionAlreadySetup, diff --git a/Remote/List.hs b/Remote/List.hs index 9d39ddd81d..80a9781f10 100644 --- a/Remote/List.hs +++ b/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. diff --git a/Remote/Mask.hs b/Remote/Mask.hs new file mode 100644 index 0000000000..04ebd2553e --- /dev/null +++ b/Remote/Mask.hs @@ -0,0 +1,205 @@ +{- Mask another remote with added encryption + - + - Copyright 2025 Joey Hess + - + - 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" diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index bf4e9d8835..bc8cd4c1e7 100644 --- a/Types/GitConfig.hs +++ b/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) diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 8ab22b6a83..25fb8ec3b2 100644 --- a/doc/git-annex.mdwn +++ b/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..annex-mask` + + Used by mask special remotes. + Normally this is automatically set up by `git annex initremote`. + * `remote..annex-externaltype` Used by external special remotes to record the type of the remote. diff --git a/git-annex.cabal b/git-annex.cabal index 162894ae20..7ffa40c35e 100644 --- a/git-annex.cabal +++ b/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