From 963239da5c2a121c26d890241b083bc1d99ad9ce Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 14 Jan 2020 12:35:08 -0400 Subject: [PATCH] separate RemoteConfig parsing basically working Many special remotes are not updated yet and are commented out. --- Annex/Drop.hs | 2 +- Annex/Import.hs | 2 - Annex/SpecialRemote/Config.hs | 89 ++++++++++++++++++++++++++++++++++- Command/Sync.hs | 1 + Command/TestRemote.hs | 22 +++++---- Config.hs | 14 ------ Config/RemoteConfig.hs | 44 ----------------- Creds.hs | 2 +- Crypto.hs | 9 ---- Remote/Directory.hs | 15 ++++-- Remote/GCrypt.hs | 27 +++++++---- Remote/Git.hs | 13 +++-- Remote/GitLFS.hs | 20 +++++--- Remote/Helper/Chunked.hs | 5 +- Remote/Helper/Encryptable.hs | 32 ++++++++----- Remote/Helper/ExportImport.hs | 77 +++++++++++++++--------------- Remote/Helper/Special.hs | 13 +++-- Remote/List.hs | 18 ++++++- Remote/P2P.hs | 3 +- Remote/Rsync.hs | 26 ++++++---- Remote/Web.hs | 3 +- Test.hs | 6 ++- Types/Crypto.hs | 13 ++++- Types/ProposedAccepted.hs | 26 ---------- Types/Remote.hs | 4 +- Types/RemoteConfig.hs | 8 +--- 26 files changed, 282 insertions(+), 212 deletions(-) delete mode 100644 Config/RemoteConfig.hs diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 52c6f02bb7..af603ac981 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -16,7 +16,7 @@ import qualified Remote import qualified Command.Drop import Command import Annex.Wanted -import Config +import Annex.SpecialRemote.Config import qualified Database.Keys import Git.FilePath diff --git a/Annex/Import.hs b/Annex/Import.hs index 7c0f88164b..0f4673a2f9 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -8,7 +8,6 @@ {-# LANGUAGE OverloadedStrings #-} module Annex.Import ( - importTree, ImportTreeConfig(..), ImportCommitConfig(..), buildImportCommit, @@ -37,7 +36,6 @@ import Annex.Export import Annex.RemoteTrackingBranch import Command import Backend -import Config import Types.Key import Types.KeySource import Messages.Progress diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs index 288cab39c4..0ce0a4d258 100644 --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -1,19 +1,27 @@ {- git-annex special remote configuration - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Annex.SpecialRemote.Config where import Common import Types.Remote (RemoteConfigField, RemoteConfig) import Types.UUID import Types.ProposedAccepted +import Types.RemoteConfig +import Config +import qualified Git.Config import qualified Data.Map as M import qualified Data.Set as S +import Data.Typeable +import GHC.Stack newtype Sameas t = Sameas t deriving (Show) @@ -34,6 +42,9 @@ lookupName :: RemoteConfig -> Maybe String lookupName c = fmap fromProposedAccepted $ M.lookup nameField c <|> M.lookup sameasNameField c +instance RemoteNameable RemoteConfig where + getRemoteName c = fromMaybe "" (lookupName c) + {- The uuid that a sameas remote is the same as is stored in this key. -} sameasUUIDField :: RemoteConfigField sameasUUIDField = Accepted "sameas-uuid" @@ -75,6 +86,22 @@ exportTreeField = Accepted "exporttree" importTreeField :: RemoteConfigField importTreeField = Accepted "importtree" +exportTree :: ParsedRemoteConfig -> Bool +exportTree = fromMaybe False . getRemoteConfigValue exportTreeField + +importTree :: ParsedRemoteConfig -> Bool +importTree = fromMaybe False . getRemoteConfigValue importTreeField + +{- Parsers for fields that are common to all special remotes. -} +commonFieldsParser :: [RemoteConfigParser] +commonFieldsParser = + [ optionalStringParser nameField + , optionalStringParser sameasNameField + , optionalStringParser sameasUUIDField + , optionalStringParser typeField + , trueFalseParser autoEnableField False + ] + {- A remote with sameas-uuid set will inherit these values from the config - of that uuid. These values cannot be overridden in the remote's config. -} sameasInherits :: S.Set RemoteConfigField @@ -124,3 +151,63 @@ findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toLis sameasuuid (u, c) = case M.lookup sameasUUIDField c of Nothing -> (u, c, Nothing) Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u)) + +{- Extracts a value from ParsedRemoteConfig. -} +getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v +getRemoteConfigValue f m = case M.lookup f m of + Just (RemoteConfigValue v) -> case cast v of + Just v' -> Just v' + Nothing -> error $ unwords + [ "getRemoteConfigValue" + , fromProposedAccepted f + , "found value of unexpected type" + , show (typeOf v) ++ "." + , "This is a bug in git-annex!" + ] + Nothing -> Nothing + +parseRemoteConfig :: RemoteConfig -> [RemoteConfigParser] -> Either String ParsedRemoteConfig +parseRemoteConfig c ps = + go [] (M.filterWithKey notaccepted c) (ps ++ commonFieldsParser) + where + go l c' [] + | M.null c' = Right (M.fromList l) + | otherwise = Left $ "Unexpected fields: " ++ + unwords (map fromProposedAccepted (M.keys c')) + go l c' ((f, p):rest) = do + v <- p (M.lookup f c) c + case v of + Just v' -> go ((f,v'):l) (M.delete f c') rest + Nothing -> go l (M.delete f c') rest + notaccepted (Proposed _) _ = True + notaccepted (Accepted _) _ = False + +optionalStringParser :: RemoteConfigField -> RemoteConfigParser +optionalStringParser f = (f, p) + where + p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v))) + p Nothing _c = Right Nothing + +yesNoParser :: RemoteConfigField -> Bool -> RemoteConfigParser +yesNoParser = genParser yesNo "yes or no" + +trueFalseParser :: RemoteConfigField -> Bool -> RemoteConfigParser +trueFalseParser = genParser Git.Config.isTrueFalse "true or false" + +genParser + :: Typeable t + => (String -> Maybe t) + -> String -- ^ description of the value + -> RemoteConfigField + -> t -- ^ fallback value + -> RemoteConfigParser +genParser parse desc f fallback = (f, p) + where + p Nothing _c = Right (Just (RemoteConfigValue fallback)) + p (Just v) _c = case parse (fromProposedAccepted v) of + Just b -> Right (Just (RemoteConfigValue b)) + Nothing -> case v of + Accepted _ -> Right (Just (RemoteConfigValue fallback)) + Proposed _ -> Left $ + "Bad value for " ++ fromProposedAccepted f ++ + " (expected " ++ desc ++ ")" diff --git a/Command/Sync.hs b/Command/Sync.hs index ff35f2219a..341d169d93 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -43,6 +43,7 @@ import Git.FilePath import qualified Remote.Git import Config import Config.GitConfig +import Annex.SpecialRemote.Config import Config.DynamicConfig import Config.Files import Annex.Wanted diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index b18c145f43..f089978392 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2014-2019 Joey Hess + - Copyright 2014-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -25,8 +25,11 @@ import Utility.CopyFile import Types.Messages import Types.Export import Types.ProposedAccepted +import Types.Crypto +import Types.RemoteConfig import Remote.Helper.ExportImport import Remote.Helper.Chunked +import Remote.Helper.Encryptable (describeEncryption) import Git.Types import Test.Tasty @@ -110,7 +113,7 @@ perform rs unavailrs exportr ks = do desc r' k = intercalate "; " $ map unwords [ [ "key size", show (fromKey keySize k) ] , [ show (getChunkConfig (Remote.config r')) ] - , ["encryption", maybe "none" fromProposedAccepted (M.lookup (Accepted "encryption") (Remote.config r'))] + , ["encryption", describeEncryption (Remote.config r')] ] descexport k1 k2 = intercalate "; " $ map unwords [ [ "exporttree=yes" ] @@ -120,16 +123,17 @@ perform rs unavailrs exportr ks = do adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) adjustChunkSize r chunksize = adjustRemoteConfig r - (M.insert (Proposed "chunk") (Proposed (show chunksize))) + (M.insert (Proposed "chunk") (RemoteConfigValue (show chunksize))) -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested. encryptionVariants :: Remote -> Annex [Remote] encryptionVariants r = do - noenc <- adjustRemoteConfig r (M.insert (Proposed "encryption") (Proposed "none")) + noenc <- adjustRemoteConfig r $ + M.insert (Proposed "encryption") (RemoteConfigValue NoneEncryption) sharedenc <- adjustRemoteConfig r $ - M.insert (Proposed "encryption") (Proposed "shared") . - M.insert (Proposed "highRandomQuality") (Proposed "false") + M.insert (Proposed "encryption") (RemoteConfigValue SharedEncryption) . + M.insert (Proposed "highRandomQuality") (RemoteConfigValue False) return $ catMaybes [noenc, sharedenc] -- Variant of a remote with exporttree disabled. @@ -141,13 +145,13 @@ disableExportTree r = maybe (error "failed disabling exportree") return exportTreeVariant :: Remote -> Annex (Maybe Remote) exportTreeVariant r = ifM (Remote.isExportSupported r) ( adjustRemoteConfig r $ - M.insert (Proposed "encryption") (Proposed "none") . - M.insert (Proposed "exporttree") (Proposed "yes") + M.insert (Proposed "encryption") (RemoteConfigValue NoneEncryption) . + M.insert (Proposed "exporttree") (RemoteConfigValue True) , return Nothing ) -- Regenerate a remote with a modified config. -adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote) +adjustRemoteConfig :: Remote -> (Remote.ParsedRemoteConfig -> Remote.ParsedRemoteConfig) -> Annex (Maybe Remote) adjustRemoteConfig r adjustconfig = do repo <- Remote.getRepo r Remote.generate (Remote.remotetype r) diff --git a/Config.hs b/Config.hs index 75f313137e..971b4207eb 100644 --- a/Config.hs +++ b/Config.hs @@ -20,10 +20,7 @@ import Config.DynamicConfig import Types.Availability import Git.Types import qualified Types.Remote as Remote -import qualified Annex.SpecialRemote.Config as SpecialRemote -import Types.ProposedAccepted -import qualified Data.Map as M import qualified Data.ByteString as S type UnqualifiedConfigKey = S.ByteString @@ -65,9 +62,6 @@ instance RemoteNameable RemoteName where instance RemoteNameable Remote where getRemoteName = Remote.name -instance RemoteNameable Remote.RemoteConfig where - getRemoteName c = fromMaybe "" (SpecialRemote.lookupName c) - {- A per-remote config setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig r key = ConfigKey $ @@ -112,14 +106,6 @@ setCrippledFileSystem b = do setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b } -exportTree :: Remote.RemoteConfig -> Bool -exportTree c = fromMaybe False $ yesNo . fromProposedAccepted - =<< M.lookup SpecialRemote.exportTreeField c - -importTree :: Remote.RemoteConfig -> Bool -importTree c = fromMaybe False $ yesNo . fromProposedAccepted - =<< M.lookup SpecialRemote.importTreeField c - yesNo :: String -> Maybe Bool yesNo "yes" = Just True yesNo "no" = Just False diff --git a/Config/RemoteConfig.hs b/Config/RemoteConfig.hs deleted file mode 100644 index d3d6e6db4e..0000000000 --- a/Config/RemoteConfig.hs +++ /dev/null @@ -1,44 +0,0 @@ -{- git-annex remote config parsing - - - - Copyright 2020 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Config.RemoteConfig where - -import qualified Data.Map as M -import Data.Typeable - -import Types.RemoteConfig -import Types.ProposedAccepted -import Config - -parseRemoteConfig :: RemoteConfig -> [RemoteConfigParser] -> Either String ParsedRemoteConfig -parseRemoteConfig c = go [] (M.filterWithKey notaccepted c) - where - go l c' [] - | M.null c' = Right (M.fromList l) - | otherwise = Left $ "Unexpected fields: " ++ - unwords (map fromProposedAccepted (M.keys c')) - go l c' ((f, p):rest) = do - v <- p (M.lookup f c) c - go ((f,v):l) (M.delete f c') rest - notaccepted (Proposed _) _ = True - notaccepted (Accepted _) _ = False - -yesNoParser :: RemoteConfigField -> Bool -> RemoteConfigParser -yesNoParser f fallback = (f, p) - where - p v _c = case v of - Nothing -> Right (RemoteConfigValue fallback) - Just v' -> case yesNo (fromProposedAccepted v') of - Just b -> Right (RemoteConfigValue b) - Nothing -> case v' of - Accepted _ -> Right (RemoteConfigValue fallback) - Proposed _ -> Left $ - "bad " ++ fromProposedAccepted f ++ - " value (expected yes or no)" - -optStringParser :: RemoteConfigField -> RemoteConfigParser -optStringParser f = (f, \v _c -> Right (RemoteConfigValue v)) diff --git a/Creds.hs b/Creds.hs index 4b6c206080..a1c81517d2 100644 --- a/Creds.hs +++ b/Creds.hs @@ -24,7 +24,7 @@ import Annex.Common import qualified Annex import Types.Creds import Types.RemoteConfig -import Config.RemoteConfig +import Annex.SpecialRemote.Config import Annex.Perms import Utility.FileMode import Crypto diff --git a/Crypto.hs b/Crypto.hs index f0971fddef..88b85aa7bc 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -39,7 +39,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.UTF8 (fromString) import Control.Monad.IO.Class -import Data.Typeable import Annex.Common import qualified Utility.Gpg as Gpg @@ -48,14 +47,6 @@ import Types.Remote import Types.Key import Annex.SpecialRemote.Config -data EncryptionMethod - = NoneEncryption - | SharedEncryption - | PubKeyEncryption - | SharedPubKeyEncryption - | HybridEncryption - deriving (Typeable, Eq) - {- The beginning of a Cipher is used for MAC'ing; the remainder is used - as the GPG symmetric encryption passphrase when using the hybrid - scheme. Note that the cipher itself is base-64 encoded, hence the diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 56cf567515..b3421e2a04 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -1,6 +1,6 @@ {- A "remote" that is just a filesystem directory. - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,6 +24,7 @@ import Types.Creds import qualified Git import Config.Cost import Config +import Annex.SpecialRemote.Config import Utility.FileMode import Remote.Helper.Special import Remote.Helper.ExportImport @@ -37,16 +38,20 @@ import Utility.InodeCache import Types.ProposedAccepted remote :: RemoteType -remote = RemoteType +remote = specialRemoteType $ RemoteType { typename = "directory" , enumerate = const (findSpecialRemotes "directory") , generate = gen + , configParser = [optionalStringParser directoryField] , setup = directorySetup , exportSupported = exportIsSupported , importSupported = importIsSupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +directoryField :: RemoteConfigField +directoryField = Accepted "directory" + +gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc cheapRemoteCost let chunkconfig = getChunkConfig c @@ -113,7 +118,7 @@ directorySetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane let dir = maybe (giveup "Specify directory=") fromProposedAccepted $ - M.lookup (Accepted "directory") c + M.lookup directoryField c absdir <- liftIO $ absPath dir liftIO $ unlessM (doesDirectoryExist absdir) $ giveup $ "Directory does not exist: " ++ absdir @@ -122,7 +127,7 @@ directorySetup _ mu _ c gc = do -- The directory is stored in git config, not in this remote's -- persistant state, so it can vary between hosts. gitConfigSpecialRemote u c' [("directory", absdir)] - return (M.delete (Accepted "directory") c', u) + return (M.delete directoryField c', u) {- Locations to try to access a given Key in the directory. - We try more than one since we used to write to different hash diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 4952d2f0a1..507a2ffd14 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -39,6 +39,7 @@ import qualified Git.Construct import qualified Annex.Branch import Config import Config.Cost +import Annex.SpecialRemote.Config import Remote.Helper.Git import Remote.Helper.Encryptable import Remote.Helper.Special @@ -59,18 +60,22 @@ import Messages.Progress import Types.ProposedAccepted remote :: RemoteType -remote = RemoteType +remote = specialRemoteType $ RemoteType { typename = "gcrypt" -- Remote.Git takes care of enumerating gcrypt remotes too, -- and will call our gen on them. , enumerate = const (return []) , generate = gen + , configParser = [optionalStringParser gitRepoField] , setup = gCryptSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gitRepoField :: RemoteConfigField +gitRepoField = Accepted "gitrepo" + +chainGen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) chainGen gcryptr u c gc rs = do g <- gitRepo -- get underlying git repo with real path, not gcrypt path @@ -78,7 +83,7 @@ chainGen gcryptr u c gc rs = do let r' = r { Git.remoteName = Git.remoteName gcryptr } gen r' u c gc rs -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen baser u c gc rs = do -- doublecheck that cache matches underlying repo's gcrypt-id -- (which might not be set), only for local repos @@ -99,15 +104,17 @@ gen baser u c gc rs = do v <- M.lookup u' <$> readRemoteLog case (Git.remoteName baser, v) of (Just remotename, Just c') -> do - setGcryptEncryption c' remotename + pc <- either giveup return $ + parseRemoteConfig c' (configParser remote) + setGcryptEncryption pc remotename storeUUIDIn (remoteConfig baser "uuid") u' setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid - gen' r u' c' gc rs + gen' r u' pc gc rs _ -> do warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r return Nothing -gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen' r u c gc rs = do cst <- remoteCost gc $ if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost @@ -188,7 +195,7 @@ unsupportedUrl :: a unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not supported" gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) -gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup (Accepted "gitrepo") c +gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c where remotename = fromJust (lookupName c) go Nothing = giveup "Specify gitrepo=" @@ -207,7 +214,9 @@ gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup (Accepted "gitr | Git.repoLocation r == url -> noop | otherwise -> error "Another remote with the same name already exists." - setGcryptEncryption c' remotename + pc <- either giveup return $ + parseRemoteConfig c' (configParser remote) + setGcryptEncryption pc remotename {- Run a git fetch and a push to the git repo in order to get - its gcrypt-id set up, so that later git annex commands @@ -323,7 +332,7 @@ shellOrRsync r ashell arsync - Also, sets gcrypt-publish-participants to avoid unncessary gpg - passphrase prompts. -} -setGcryptEncryption :: RemoteConfig -> String -> Annex () +setGcryptEncryption :: ParsedRemoteConfig -> String -> Annex () setGcryptEncryption c remotename = do let participants = remoteconfig Git.GCrypt.remoteParticipantConfigKey case extractCipher c of diff --git a/Remote/Git.hs b/Remote/Git.hs index 037344d958..c910a5c524 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -37,6 +37,7 @@ import qualified Annex.SpecialRemote.Config as SpecialRemote import Utility.Tmp import Config import Config.Cost +import Annex.SpecialRemote.Config import Config.DynamicConfig import Annex.Init import Types.CleanupActions @@ -79,11 +80,15 @@ remote = RemoteType { typename = "git" , enumerate = list , generate = gen + , configParser = [optionalStringParser locationField] , setup = gitSetup , exportSupported = exportUnsupported , importSupported = importUnsupported } +locationField :: RemoteConfigField +locationField = Accepted "location" + list :: Bool -> Annex [Git.Repo] list autoinit = do c <- fromRepo Git.config @@ -113,7 +118,7 @@ gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remote gitSetup Init mu _ c _ = do let location = fromMaybe (giveup "Specify location=url") $ Url.parseURIRelaxed . fromProposedAccepted - =<< M.lookup (Accepted "location") c + =<< M.lookup locationField c rs <- Annex.getGitRemotes u <- case filter (\r -> Git.location r == Git.Url location) rs of [r] -> getRepoUUID r @@ -127,7 +132,7 @@ gitSetup (Enable _) (Just u) _ c _ = do [ Param "remote" , Param "add" , Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c) - , Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup (Accepted "location") c) + , Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c) ] return (c, u) gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid" @@ -153,7 +158,7 @@ configRead autoinit r = do Just r' -> return r' _ -> return r -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs -- Remote.GitLFS may be used with a repo that is also encrypted -- with gcrypt so is checked first. @@ -204,7 +209,7 @@ gen r u c gc rs , remoteStateHandle = rs } -unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +unavailable :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) unavailable r = gen r' where r' = case Git.location r of diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index d6f94e2fc2..8ed0586ebc 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -1,6 +1,6 @@ {- Using git-lfs as a remote. - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -25,6 +25,7 @@ import qualified Git.GCrypt import qualified Git.Credential as Git import Config import Config.Cost +import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Remote.Helper.Git @@ -53,18 +54,22 @@ import qualified Data.Text.Encoding as E import qualified Control.Concurrent.MSemN as MSemN remote :: RemoteType -remote = RemoteType +remote = specialRemoteType $ RemoteType { typename = "git-lfs" -- Remote.Git takes care of enumerating git-lfs remotes too, -- and will call our gen on them. , enumerate = const (return []) , generate = gen + , configParser = [optionalStringParser urlField] , setup = mySetup , exportSupported = exportUnsupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +urlField :: RemoteConfigField +urlField = Accepted "url" + +gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do -- If the repo uses gcrypt, get the underlaying repo without the -- gcrypt url, to do LFS endpoint discovery on. @@ -128,9 +133,10 @@ mySetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu (c', _encsetup) <- encryptionSetup c gc - case (isEncrypted c', Git.GCrypt.urlPrefix `isPrefixOf` url) of + pc <- either giveup return $ parseRemoteConfig c' (configParser remote) + case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of (False, False) -> noop - (True, True) -> Remote.GCrypt.setGcryptEncryption c' remotename + (True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename (True, False) -> unlessM (Annex.getState Annex.force) $ giveup $ unwords $ [ "Encryption is enabled for this remote," @@ -160,7 +166,7 @@ mySetup _ mu _ c gc = do return (c', u) where url = maybe (giveup "Specify url=") fromProposedAccepted - (M.lookup (Accepted "url") c) + (M.lookup urlField c) remotename = fromJust (lookupName c) {- Check if a remote's url is one known to belong to a git-lfs repository. @@ -180,7 +186,7 @@ configKnownUrl r t <- fromProposedAccepted <$> M.lookup Annex.SpecialRemote.Config.typeField c u <- fromProposedAccepted - <$> M.lookup (Accepted "url") c + <$> M.lookup urlField c let u' = Git.Remote.parseRemoteLocation u g return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u' && t == typename remote diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 71df55cbcc..b68cbd511d 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -28,7 +28,6 @@ import Utility.Metered import Crypto (EncKey) import Backend (isStableKey) import Annex.SpecialRemote.Config -import Config.RemoteConfig import qualified Data.ByteString.Lazy as L @@ -52,8 +51,8 @@ noChunks _ = False chunkConfigParser :: [RemoteConfigParser] chunkConfigParser = - [ optStringParser chunksizeField - , optStringParser chunkField + [ optionalStringParser chunksizeField + , optionalStringParser chunkField ] getChunkConfig :: ParsedRemoteConfig -> ChunkConfig diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 69589e24ce..dda8020ac5 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -13,6 +13,7 @@ module Remote.Helper.Encryptable ( noEncryptionUsed, encryptionAlreadySetup, encryptionConfigParser, + parseEncryptionConfig, remoteCipher, remoteCipher', embedCreds, @@ -23,12 +24,12 @@ module Remote.Helper.Encryptable ( ) where import qualified Data.Map as M +import qualified Data.Set as S import qualified "sandi" Codec.Binary.Base64 as B64 import qualified Data.ByteString as B import Annex.Common import Types.Remote -import Config.RemoteConfig import Crypto import Types.Crypto import Types.ProposedAccepted @@ -52,18 +53,25 @@ encryptionAlreadySetup = EncryptionIsSetup encryptionConfigParser :: [RemoteConfigParser] encryptionConfigParser = - [ (encryptionField, \v c -> RemoteConfigValue <$> parseEncryptionMethod (fmap fromProposedAccepted v) c) - , optStringParser cipherField - , optStringParser cipherkeysField - , optStringParser pubkeysField + [ (encryptionField, \v c -> Just . RemoteConfigValue <$> parseEncryptionMethod (fmap fromProposedAccepted v) c) + , optionalStringParser cipherField + , optionalStringParser cipherkeysField + , optionalStringParser pubkeysField , yesNoParser embedCredsField False - , (macField, \v _c -> RemoteConfigValue <$> parseMac v) - , optStringParser (Accepted "keyid") - , optStringParser (Accepted "keyid+") - , optStringParser (Accepted "keyid-") - , (Accepted "highRandomQuality", \v _c -> RemoteConfigValue <$> parseHighRandomQuality (fmap fromProposedAccepted v)) + , (macField, \v _c -> Just . RemoteConfigValue <$> parseMac v) + , optionalStringParser (Accepted "keyid") + , optionalStringParser (Accepted "keyid+") + , optionalStringParser (Accepted "keyid-") + , (Accepted "highRandomQuality", \v _c -> Just . RemoteConfigValue <$> parseHighRandomQuality (fmap fromProposedAccepted v)) ] +encryptionConfigs :: S.Set RemoteConfigField +encryptionConfigs = S.fromList (map fst encryptionConfigParser) + +-- Parse only encryption fields, ignoring all others. +parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig +parseEncryptionConfig c = parseRemoteConfig (M.restrictKeys c encryptionConfigs) encryptionConfigParser + parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod parseEncryptionMethod (Just "none") _ = Right NoneEncryption parseEncryptionMethod (Just "shared") _ = Right SharedEncryption @@ -100,7 +108,7 @@ parseMac (Just (Proposed s)) = case readMac s of - could opt to use a shared cipher, which is stored unencrypted. -} encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup) encryptionSetup c gc = do - pc <- either giveup return $ parseRemoteConfig c encryptionConfigParser + pc <- either giveup return $ parseEncryptionConfig c cmd <- gpgCmd <$> Annex.getGitConfig maybe (genCipher pc cmd) (updateCipher pc cmd) (extractCipher pc) where @@ -228,7 +236,7 @@ isEncrypted = isJust . extractCipher describeEncryption :: ParsedRemoteConfig -> String describeEncryption c = case extractCipher c of - Nothing -> "none" + Nothing -> "none" ++ show (getRemoteConfigValue cipherField c :: Maybe String) ++ show (M.keys c) Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")" nameCipher :: StorableCipher -> String diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 2af981e545..04f41322d5 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -20,20 +20,18 @@ import qualified Database.Export as Export import qualified Database.ContentIdentifier as ContentIdentifier import Annex.Export import Annex.LockFile -import Config -import Annex.SpecialRemote.Config (exportTreeField, importTreeField) +import Annex.SpecialRemote.Config import Git.Types (fromRef) import Logs.Export import Logs.ContentIdentifier (recordContentIdentifier) -import qualified Data.Map as M import Control.Concurrent.STM -- | Use for remotes that do not support exports. class HasExportUnsupported a where exportUnsupported :: a -instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where +instance HasExportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where exportUnsupported = \_ _ -> return False instance HasExportUnsupported (ExportActions Annex) where @@ -52,7 +50,7 @@ instance HasExportUnsupported (ExportActions Annex) where class HasImportUnsupported a where importUnsupported :: a -instance HasImportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where +instance HasImportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where importUnsupported = \_ _ -> return False instance HasImportUnsupported (ImportActions Annex) where @@ -65,62 +63,67 @@ instance HasImportUnsupported (ImportActions Annex) where , checkPresentExportWithContentIdentifier = \_ _ _ -> return False } -exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool +exportIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool exportIsSupported = \_ _ -> return True -importIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool +importIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool importIsSupported = \_ _ -> return True -- | 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' } +adjustExportImportRemoteType rt = rt + { setup = setup' + , configParser = configparser + } where - setup' st mu cp c gc = - let checkconfig supported configured configfield cont = do - case parseProposedAccepted configfield c yesNo False "yes or no" of - Right _ -> noop - Left err -> giveup err - ifM (supported rt c gc) + configparser = configParser rt ++ exportImportConfigParser + setup' st mu cp c gc = do + pc <- either giveup return $ parseRemoteConfig c configparser + let checkconfig supported configured configfield cont = + ifM (supported rt pc gc) ( case st of Init - | configured c && isEncrypted c -> + | configured pc && isEncrypted pc -> giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield | otherwise -> cont - Enable oldc - | configured c /= configured oldc -> - giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote" - | otherwise -> cont - , if configured c + Enable oldc -> + let oldpc = either mempty id $ parseRemoteConfig oldc configparser + in if configured pc /= configured oldpc + then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote" + else cont + , if configured pc then giveup $ fromProposedAccepted configfield ++ " is not supported by this special remote" else cont ) - in checkconfig exportSupported exportTree exportTreeField $ + checkconfig exportSupported exportTree exportTreeField $ checkconfig importSupported importTree importTreeField $ - if importTree c && not (exportTree c) + if importTree pc && not (exportTree pc) then giveup "cannot enable importtree=yes without also enabling exporttree=yes" else setup rt st mu cp c gc +exportImportConfigParser :: [RemoteConfigParser] +exportImportConfigParser = + [ yesNoParser exportTreeField False + , yesNoParser importTreeField False + ] + -- | Adjust a remote to support exporttree=yes and importree=yes. -- -- Note that all remotes with importree=yes also have exporttree=yes. adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote -adjustExportImport r rs = case M.lookup exportTreeField (config r) of +adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) of Nothing -> return $ notexport r - Just c -> case yesNo (fromProposedAccepted c) of - Just True -> ifM (isExportSupported r) - ( do - exportdbv <- prepexportdb - r' <- isexport exportdbv - if importTree (config r) - then isimport r' exportdbv - else return r' - , return $ notexport r - ) - Just False -> return $ notexport r - Nothing -> do - warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export" - return $ notexport r + Just True -> ifM (isExportSupported r) + ( do + exportdbv <- prepexportdb + r' <- isexport exportdbv + if importTree (config r) + then isimport r' exportdbv + else return r' + , return $ notexport r + ) + Just False -> return $ notexport r where notexport r' = notimport r' { exportActions = exportUnsupported diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 9c31f4982f..26e544a22f 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -31,6 +31,7 @@ module Remote.Helper.Special ( specialRemoteConfigParser, SpecialRemoteCfg(..), specialRemoteCfg, + specialRemoteType, specialRemote, specialRemote', lookupName, @@ -158,9 +159,6 @@ type RemoteModifier -> Remote -> Remote -specialRemoteConfigParser :: [RemoteConfigParser] -specialRemoteConfigParser = chunkConfigParser ++ encryptionConfigParser - data SpecialRemoteCfg = SpecialRemoteCfg { chunkConfig :: ChunkConfig , displayProgress :: Bool @@ -169,6 +167,15 @@ data SpecialRemoteCfg = SpecialRemoteCfg specialRemoteCfg :: ParsedRemoteConfig -> SpecialRemoteCfg specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True +-- Modifies a base RemoteType to support chunking and encryption configs. +specialRemoteType :: RemoteType -> RemoteType +specialRemoteType r = r + { configParser = configParser r ++ specialRemoteConfigParser + } + +specialRemoteConfigParser :: [RemoteConfigParser] +specialRemoteConfigParser = chunkConfigParser ++ encryptionConfigParser + -- Modifies a base Remote to support both chunking and encryption, -- which special remotes typically should support. -- diff --git a/Remote/List.hs b/Remote/List.hs index 3e7ca9fa73..e1621a3a29 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -1,6 +1,6 @@ {- git-annex remote list - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,17 +20,21 @@ import Annex.UUID import Remote.Helper.Hooks import Remote.Helper.ReadOnly import Remote.Helper.ExportImport +import Annex.SpecialRemote.Config import qualified Git import qualified Git.Config import qualified Remote.Git import qualified Remote.GCrypt import qualified Remote.P2P +{- #ifdef WITH_S3 import qualified Remote.S3 #endif import qualified Remote.Bup +-} import qualified Remote.Directory +{- import qualified Remote.Rsync import qualified Remote.Web import qualified Remote.BitTorrent @@ -41,20 +45,26 @@ import qualified Remote.Adb import qualified Remote.Tahoe import qualified Remote.Glacier import qualified Remote.Ddar +-} import qualified Remote.GitLFS +{- import qualified Remote.Hook import qualified Remote.External +-} remoteTypes :: [RemoteType] remoteTypes = map adjustExportImportRemoteType [ Remote.Git.remote , Remote.GCrypt.remote , Remote.P2P.remote +{- #ifdef WITH_S3 , Remote.S3.remote #endif , Remote.Bup.remote +-} , Remote.Directory.remote +{- , Remote.Rsync.remote , Remote.Web.remote , Remote.BitTorrent.remote @@ -65,9 +75,12 @@ remoteTypes = map adjustExportImportRemoteType , Remote.Tahoe.remote , Remote.Glacier.remote , Remote.Ddar.remote +-} , Remote.GitLFS.remote +{- , Remote.Hook.remote , Remote.External.remote +-} ] {- Builds a list of all available Remotes. @@ -109,7 +122,8 @@ remoteGen m t g = do let cu = fromMaybe u $ remoteAnnexConfigUUID gc let rs = RemoteStateHandle cu let c = fromMaybe M.empty $ M.lookup cu m - generate t g u c gc rs >>= \case + let pc = either mempty id (parseRemoteConfig c (configParser t)) + generate t g u pc gc rs >>= \case Nothing -> return Nothing Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs diff --git a/Remote/P2P.hs b/Remote/P2P.hs index 755de1631e..28c75a0be0 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -36,12 +36,13 @@ remote = RemoteType -- and will call chainGen on them. , enumerate = const (return []) , generate = \_ _ _ _ _ -> return Nothing + , configParser = [] , setup = error "P2P remotes are set up using git-annex p2p" , exportSupported = exportUnsupported , importSupported = importUnsupported } -chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +chainGen :: P2PAddress -> Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) chainGen addr r u c gc rs = do connpool <- mkConnectionPool cst <- remoteCost gc veryExpensiveRemoteCost diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 8b331503b9..959fd4dd7e 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -1,6 +1,6 @@ {- A remote that is only accessible by rsync. - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -42,20 +42,31 @@ import Types.Creds import Annex.DirHashes import Utility.Tmp.Dir import Utility.SshHost +import Annex.SpecialRemote.Config import qualified Data.Map as M remote :: RemoteType -remote = RemoteType +remote = specialRemoteType $ RemoteType { typename = "rsync" , enumerate = const (findSpecialRemotes "rsyncurl") , generate = gen + , configParser = + [ yesNoParser shellEscapeField True + , optionalStringParser rsyncUrlField + ] , setup = rsyncSetup , exportSupported = exportIsSupported , importSupported = importUnsupported } -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +shellEscapeField :: RemoteConfigField +shellEscapeField = Accepted "shellescape" + +rsyncUrlField :: RemoteConfigField +rsyncUrlField = Accepted "rsyncurl" + +gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u c gc rs = do cst <- remoteCost gc expensiveRemoteCost (transport, url) <- rsyncTransport gc $ @@ -112,7 +123,7 @@ gen r u c gc rs = do -- Rsync displays its own progress. { displayProgress = False } -genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts +genRsyncOpts :: ParsedRemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts genRsyncOpts c gc transport url = RsyncOpts { rsyncUrl = url , rsyncOptions = appendtransport $ opts [] @@ -120,7 +131,7 @@ genRsyncOpts c gc transport url = RsyncOpts opts (remoteAnnexRsyncUploadOptions gc) , rsyncDownloadOptions = appendtransport $ opts (remoteAnnexRsyncDownloadOptions gc) - , rsyncShellEscape = (yesNo . fromProposedAccepted =<< M.lookup (Accepted "shellescape") c) /= Just False + , rsyncShellEscape = fromMaybe True (getRemoteConfigValue shellEscapeField c) } where appendtransport l = (++ l) <$> transport @@ -163,10 +174,7 @@ rsyncSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane let url = maybe (giveup "Specify rsyncurl=") fromProposedAccepted $ - M.lookup (Accepted "rsyncurl") c - case parseProposedAccepted (Accepted "shellescape") c yesNo False "yes or no" of - Left err -> giveup err - _ -> noop + M.lookup rsyncUrlField c (c', _encsetup) <- encryptionSetup c gc -- The rsyncurl is stored in git config, not only in this remote's diff --git a/Remote/Web.hs b/Remote/Web.hs index 810c2f027e..2f6ab81597 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -27,6 +27,7 @@ remote = RemoteType { typename = "web" , enumerate = list , generate = gen + , configParser = [] , setup = error "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported @@ -40,7 +41,7 @@ list _autoinit = do r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown) return [r] -gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r _ c gc rs = do cst <- remoteCost gc expensiveRemoteCost return $ Just Remote diff --git a/Test.hs b/Test.hs index 7bcfdd3560..d193e8c8cc 100644 --- a/Test.hs +++ b/Test.hs @@ -1614,7 +1614,7 @@ test_crypto = do annexed_present annexedfile {- Ensure the configuration complies with the encryption scheme, and - that all keys are encrypted properly for the given directory remote. -} - testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher c of + testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks -> checkKeys cip Nothing Just cip@(Crypto.EncryptedCipher encipher v ks') @@ -1622,6 +1622,8 @@ test_crypto = do checkKeys cip (Just v) <&&> checkCipher encipher ks' _ -> return False where + pc =either mempty id $ + Remote.Helper.Encryptable.parseEncryptionConfig c keysMatch (Utility.Gpg.KeyIds ks') = maybe False (\(Utility.Gpg.KeyIds ks2) -> sort (nub ks2) == sort (nub ks')) ks @@ -1630,7 +1632,7 @@ test_crypto = do checkScheme Types.Crypto.PubKey = scheme == "pubkey" checkKeys cip mvariant = do dummycfg <- Types.GitConfig.dummyRemoteGitConfig - let encparams = (mempty :: Types.Remote.RemoteConfig, dummycfg) + let encparams = (mempty :: Types.Remote.ParsedRemoteConfig, dummycfg) cipher <- Crypto.decryptCipher gpgcmd encparams cip files <- filterM doesFileExist $ map ("dir" ) $ concatMap (serializeKeys cipher) keys diff --git a/Types/Crypto.hs b/Types/Crypto.hs index 7dd860934a..b1293a2bbd 100644 --- a/Types/Crypto.hs +++ b/Types/Crypto.hs @@ -1,11 +1,12 @@ {- git-annex crypto types - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Types.Crypto ( + EncryptionMethod(..), Cipher(..), StorableCipher(..), EncryptedCipherVariant(..), @@ -21,6 +22,16 @@ module Types.Crypto ( import Utility.Hash import Utility.Gpg (KeyIds(..)) +import Data.Typeable + +data EncryptionMethod + = NoneEncryption + | SharedEncryption + | PubKeyEncryption + | SharedPubKeyEncryption + | HybridEncryption + deriving (Typeable, Eq) + -- XXX ideally, this would be a locked memory region data Cipher = Cipher String | MacOnlyCipher String diff --git a/Types/ProposedAccepted.hs b/Types/ProposedAccepted.hs index b0c3f2679b..a48c94546a 100644 --- a/Types/ProposedAccepted.hs +++ b/Types/ProposedAccepted.hs @@ -7,7 +7,6 @@ module Types.ProposedAccepted where -import qualified Data.Map as M import Test.QuickCheck -- | A value that may be proposed, or accepted. @@ -37,28 +36,3 @@ instance Arbitrary t => Arbitrary (ProposedAccepted t) where [ Proposed <$> arbitrary , Accepted <$> arbitrary ] - --- | Looks up a config in the map, and parses its value if found. --- --- Accepted values will always result in a Right, using a fallback value --- if unable to parse. --- --- Proposed values that cannot be parsed will result in a Left message. -parseProposedAccepted - :: ProposedAccepted String - -> M.Map (ProposedAccepted String) (ProposedAccepted v) -- config map - -> (v -> Maybe a) -- ^ parse the value - -> a -- ^ fallback used when accepted value cannot be parsed - -> String -- ^ short description of expected value - -> Either String (Maybe a) -parseProposedAccepted k m parser fallback desc = - case M.lookup k m of - Nothing -> Right Nothing - Just (Proposed v) -> case parser v of - Nothing -> Left $ - "bad " ++ fromProposedAccepted k ++ - " value (expected " ++ desc ++ ")" - Just a -> Right (Just a) - Just (Accepted v) -> case parser v of - Nothing -> Right (Just fallback) - Just a -> Right (Just a) diff --git a/Types/Remote.hs b/Types/Remote.hs index 2cc2df35fc..93ee1c53ad 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -57,10 +57,10 @@ data RemoteTypeA a = RemoteType -- enumerates remotes of this type -- The Bool is True if automatic initialization of remotes is desired , enumerate :: Bool -> a [Git.Repo] + -- generates a remote of this type + , generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a)) -- parse configs of remotes of this type , configParser :: [RemoteConfigParser] - -- generates a remote of this type - , generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a)) -- initializes or enables a remote , setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) -- check if a remote of this type is able to support export diff --git a/Types/RemoteConfig.hs b/Types/RemoteConfig.hs index 89353f3024..5035aa036f 100644 --- a/Types/RemoteConfig.hs +++ b/Types/RemoteConfig.hs @@ -28,12 +28,6 @@ type ParsedRemoteConfig = M.Map RemoteConfigField RemoteConfigValue data RemoteConfigValue where RemoteConfigValue :: Typeable v => v -> RemoteConfigValue -{- Extracts the value, if the field was parsed to the requested type. -} -getRemoteConfigValue :: Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v -getRemoteConfigValue f m = case M.lookup f m of - Just (RemoteConfigValue v) -> cast v - Nothing -> Nothing - {- Parse a field's value provided by the user into a RemoteConfigValue. - - The RemoteConfig is provided to the parser function for cases @@ -43,4 +37,4 @@ getRemoteConfigValue f m = case M.lookup f m of - Presence of fields that are not included in this list will cause - a parse failure. -} -type RemoteConfigParser = (RemoteConfigField, Maybe (ProposedAccepted String) -> RemoteConfig -> Either String RemoteConfigValue) +type RemoteConfigParser = (RemoteConfigField, Maybe (ProposedAccepted String) -> RemoteConfig -> Either String (Maybe RemoteConfigValue)) -- 2.30.2