diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs index a360919890..3041d54b3b 100644 --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -22,6 +22,7 @@ import Types.TrustLevel import Types.UUID import Types.MetaData import Types.Remote +import Types.ProposedAccepted import Annex.SpecialRemote.Config import qualified Data.Map as M @@ -85,7 +86,7 @@ dropDead trustmap remoteconfigmap f content = case getLogVariety f of trustmap' = trustmap `M.union` M.map (const DeadTrusted) (M.filter sameasdead remoteconfigmap) sameasdead cm = - case toUUID <$> M.lookup sameasUUIDField cm of + case toUUID . fromProposedAccepted <$> M.lookup sameasUUIDField cm of Nothing -> False Just u' -> M.lookup u' trustmap == Just DeadTrusted minimizesameasdead u l diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index fe2c2e6923..761f4397f3 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -39,6 +39,7 @@ import Types.GitConfig import Config.GitConfig import Git.FilePath import Types.Remote (RemoteConfig) +import Types.ProposedAccepted import Annex.CheckAttr import Git.CheckAttr (unspecifiedAttr) import qualified Git.Config @@ -155,8 +156,8 @@ preferredContentKeylessTokens pcd = , SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir) ] ++ commonKeylessTokens LimitAnnexFiles where - preferreddir = fromMaybe "public" $ - M.lookup "preferreddir" =<< (`M.lookup` configMap pcd) =<< repoUUID pcd + preferreddir = maybe "public" fromProposedAccepted $ + M.lookup (Accepted "preferreddir") =<< (`M.lookup` configMap pcd) =<< repoUUID pcd preferredContentKeyedTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)] preferredContentKeyedTokens pcd = diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs index 4d5cbb4a77..4a40127a97 100644 --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -17,6 +17,7 @@ import Annex.SpecialRemote.Config import Remote (remoteTypes) import Types.Remote (RemoteConfig, SetupStage(..), typename, setup) import Types.GitConfig +import Types.ProposedAccepted import Config import Remote.List import Logs.Remote @@ -49,10 +50,10 @@ newConfig -- when sameas is used -> RemoteConfig newConfig name sameas fromuser m = case sameas of - Nothing -> M.insert nameField name fromuser + Nothing -> M.insert nameField (Proposed name) fromuser Just (Sameas u) -> addSameasInherited m $ M.fromList - [ (sameasNameField, name) - , (sameasUUIDField, fromUUID u) + [ (sameasNameField, Proposed name) + , (sameasUUIDField, Proposed (fromUUID u)) ] `M.union` fromuser specialRemoteMap :: Annex (M.Map UUID RemoteName) @@ -66,7 +67,8 @@ specialRemoteMap = do {- find the remote type -} findType :: RemoteConfig -> Either String RemoteType -findType config = maybe unspecified specified $ M.lookup typeField config +findType config = maybe unspecified (specified . fromProposedAccepted) $ + M.lookup typeField config where unspecified = Left "Specify the type of remote with type=" specified s = case filter (findtype s) remoteTypes of @@ -94,7 +96,8 @@ autoEnable = do _ -> return () where configured rc = fromMaybe False $ - Git.Config.isTrueFalse =<< M.lookup autoEnableField rc + Git.Config.isTrueFalse . fromProposedAccepted + =<< M.lookup autoEnableField rc canenable u = (/= DeadTrusted) <$> lookupTrust u getenabledremotes = M.fromList . map (\r -> (getcu r, r)) diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs index e09ae8ecc7..a2f40b1ee6 100644 --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -10,6 +10,7 @@ module Annex.SpecialRemote.Config where import Common import Types.Remote (RemoteConfigField, RemoteConfig) import Types.UUID +import Types.ProposedAccepted import qualified Data.Map as M import qualified Data.Set as S @@ -22,44 +23,54 @@ newtype ConfigFrom t = ConfigFrom t {- The name of a configured remote is stored in its config using this key. -} nameField :: RemoteConfigField -nameField = "name" +nameField = Accepted "name" {- The name of a sameas remote is stored using this key instead. - This prevents old versions of git-annex getting confused. -} sameasNameField :: RemoteConfigField -sameasNameField = "sameas-name" +sameasNameField = Accepted "sameas-name" lookupName :: RemoteConfig -> Maybe String -lookupName c = M.lookup nameField c <|> M.lookup sameasNameField c +lookupName c = fmap fromProposedAccepted $ + M.lookup nameField c <|> M.lookup sameasNameField c {- The uuid that a sameas remote is the same as is stored in this key. -} sameasUUIDField :: RemoteConfigField -sameasUUIDField = "sameas-uuid" +sameasUUIDField = Accepted "sameas-uuid" {- The type of a remote is stored in its config using this key. -} typeField :: RemoteConfigField -typeField = "type" +typeField = Accepted "type" autoEnableField :: RemoteConfigField -autoEnableField = "autoenable" +autoEnableField = Accepted "autoenable" encryptionField :: RemoteConfigField -encryptionField = "encryption" +encryptionField = Accepted "encryption" macField :: RemoteConfigField -macField = "mac" +macField = Accepted "mac" cipherField :: RemoteConfigField -cipherField = "cipher" +cipherField = Accepted "cipher" cipherkeysField :: RemoteConfigField -cipherkeysField = "cipherkeys" +cipherkeysField = Accepted "cipherkeys" pubkeysField :: RemoteConfigField -pubkeysField = "pubkeys" +pubkeysField = Accepted "pubkeys" chunksizeField :: RemoteConfigField -chunksizeField = "chunksize" +chunksizeField = Accepted "chunksize" + +embedCredsField :: RemoteConfigField +embedCredsField = Accepted "embedcreds" + +exportTreeField :: RemoteConfigField +exportTreeField = Accepted "exporttree" + +importTreeField :: RemoteConfigField +importTreeField = Accepted "importtree" {- 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. -} @@ -92,7 +103,8 @@ addSameasInherited m c = case findSameasUUID c of M.restrictKeys parentc sameasInherits findSameasUUID :: RemoteConfig -> Maybe (Sameas UUID) -findSameasUUID c = Sameas . toUUID <$> M.lookup sameasUUIDField c +findSameasUUID c = Sameas . toUUID . fromProposedAccepted + <$> M.lookup sameasUUIDField c {- Remove any fields inherited from a sameas-uuid. When storing a - RemoteConfig, those fields don't get stored, since they were already @@ -108,4 +120,4 @@ findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toLis where sameasuuid (u, c) = case M.lookup sameasUUIDField c of Nothing -> (u, c, Nothing) - Just u' -> (toUUID u', c, Just (ConfigFrom u)) + Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u)) diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs index 6215fba389..01226e0640 100644 --- a/Assistant/Gpg.hs +++ b/Assistant/Gpg.hs @@ -11,6 +11,7 @@ import Utility.Gpg import Utility.UserInfo import Types.Remote (RemoteConfigField) import Annex.SpecialRemote.Config +import Types.ProposedAccepted import qualified Data.Map as M import Control.Applicative @@ -31,7 +32,7 @@ data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption deriving (Eq) {- Generates Remote configuration for encryption. -} -configureEncryption :: EnableEncryption -> (RemoteConfigField, String) -configureEncryption SharedEncryption = (encryptionField, "shared") -configureEncryption NoEncryption = (encryptionField, "none") -configureEncryption HybridEncryption = (encryptionField, "hybrid") +configureEncryption :: EnableEncryption -> (RemoteConfigField, ProposedAccepted String) +configureEncryption SharedEncryption = (encryptionField, Proposed "shared") +configureEncryption NoEncryption = (encryptionField, Proposed "none") +configureEncryption HybridEncryption = (encryptionField, Proposed "hybrid") diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index ba4df37f97..cf62cc463e 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -30,6 +30,7 @@ import Assistant.Gpg import Utility.Gpg (KeyId) import Types.GitConfig import Config +import Types.ProposedAccepted import qualified Data.Map as M @@ -59,19 +60,19 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $ go (Just (u, c, mcu)) = setupSpecialRemote name Rsync.remote config Nothing (Just u, R.Enable c, c) mcu config = M.fromList - [ (encryptionField, "shared") - , ("rsyncurl", location) - , ("type", "rsync") + [ (encryptionField, Proposed "shared") + , (Proposed "rsyncurl", Proposed location) + , (typeField, Proposed "rsync") ] {- Inits a gcrypt special remote, and returns its name. -} makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName makeGCryptRemote remotename location keyid = initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList - [ ("type", "gcrypt") - , ("gitrepo", location) + [ (typeField, Proposed "gcrypt") + , (Proposed "gitrepo", Proposed location) , configureEncryption HybridEncryption - , ("keyid", keyid) + , (Proposed "keyid", Proposed keyid) ] type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName @@ -105,7 +106,7 @@ setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) mcu = do - assistant, because otherwise GnuPG may block once the entropy - pool is drained, and as of now there's no way to tell the user - to perform IO actions to refill the pool. -} - let weakc = M.insert "highRandomQuality" "false" $ M.union config c + let weakc = M.insert (Proposed "highRandomQuality") (Proposed "false") (M.union config c) dummycfg <- liftIO dummyRemoteGitConfig (c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg case mcu of diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index c924a78800..8e99b1b048 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -25,6 +25,7 @@ import Creds import Assistant.Gpg import Git.Types (RemoteName) import Annex.SpecialRemote.Config +import Types.ProposedAccepted import qualified Data.Text as T import qualified Data.Map as M @@ -131,10 +132,10 @@ postAddS3R = awsConfigurator $ do let name = T.unpack $ repoName input makeAWSRemote initSpecialRemote S3.remote TransferGroup (extractCreds input) name $ M.fromList [ configureEncryption $ enableEncryption input - , ("type", "S3") - , ("datacenter", T.unpack $ datacenter input) - , ("storageclass", show $ storageClass input) - , ("chunk", "1MiB") + , (typeField, Proposed "S3") + , (Proposed "datacenter", Proposed $ T.unpack $ datacenter input) + , (Proposed "storageclass", Proposed $ show $ storageClass input) + , (Proposed "chunk", Proposed "1MiB") ] _ -> $(widgetFile "configurators/adds3") #else @@ -155,8 +156,8 @@ postAddGlacierR = glacierConfigurator $ do let name = T.unpack $ repoName input makeAWSRemote initSpecialRemote Glacier.remote SmallArchiveGroup (extractCreds input) name $ M.fromList [ configureEncryption $ enableEncryption input - , ("type", "glacier") - , ("datacenter", T.unpack $ datacenter input) + , (typeField, Proposed "glacier") + , (Proposed "datacenter", Proposed $ T.unpack $ datacenter input) ] _ -> $(widgetFile "configurators/addglacier") #else @@ -222,7 +223,7 @@ makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = getRepoInfo :: RemoteConfig -> Widget getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|] where - bucket = fromMaybe "" $ M.lookup "bucket" c + bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c #ifdef WITH_S3 previouslyUsedAWSCreds :: Annex (Maybe CredPair) diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 5f5e9ffed7..5c448b3f45 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -46,6 +46,8 @@ import Config import Config.GitConfig import Config.DynamicConfig import Types.Group +import Types.ProposedAccepted +import Annex.SpecialRemote.Config import qualified Data.Text as T import qualified Data.Map as M @@ -125,7 +127,7 @@ setRepoConfig uuid mremote oldc newc = do case M.lookup uuid m of Nothing -> noop Just remoteconfig -> configSet uuid $ - M.insert "preferreddir" dir remoteconfig + M.insert (Proposed "preferreddir") (Proposed dir) remoteconfig when groupChanged $ do liftAnnex $ case repoGroup newc of RepoGroupStandard g -> setStandardGroup uuid g @@ -243,7 +245,7 @@ checkAssociatedDirectory cfg (Just r) = do _ -> noop getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget -getRepoInfo (Just r) (Just c) = case M.lookup "type" c of +getRepoInfo (Just r) (Just c) = case fromProposedAccepted <$> M.lookup typeField c of Just "S3" #ifdef WITH_S3 | S3.configIA c -> IA.getRepoInfo c diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index 04feb965b6..d34f5d5f7c 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -25,6 +25,7 @@ import Types.Remote (RemoteConfig) import qualified Annex.Url as Url import Creds import Annex.SpecialRemote.Config +import Types.ProposedAccepted import qualified Data.Text as T import qualified Data.Map as M @@ -131,21 +132,22 @@ postAddIAR = iaConfigurator $ do case result of FormSuccess input -> liftH $ do let name = escapeBucket $ T.unpack $ itemName input + let wrap (k, v) = (Proposed k, Proposed v) + let c = map wrap $ catMaybes + [ Just ("type", "S3") + , Just ("host", S3.iaHost) + , Just ("bucket", escapeHeader name) + , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input) + , if mediaType input == MediaOmitted + then Nothing + else Just ("x-archive-mediatype", formatMediaType $ mediaType input) + , (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input) + -- Make item show up ASAP. + , Just ("x-archive-interactive-priority", "1") + , Just ("preferreddir", name) + ] AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $ - M.fromList $ catMaybes - [ Just $ configureEncryption NoEncryption - , Just ("type", "S3") - , Just ("host", S3.iaHost) - , Just ("bucket", escapeHeader name) - , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input) - , if mediaType input == MediaOmitted - then Nothing - else Just ("x-archive-mediatype", formatMediaType $ mediaType input) - , (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input) - -- Make item show up ASAP. - , Just ("x-archive-interactive-priority", "1") - , Just ("preferreddir", name) - ] + M.fromList $ configureEncryption NoEncryption : c _ -> $(widgetFile "configurators/addia") #else postAddIAR = giveup "S3 not supported by this build" @@ -202,7 +204,7 @@ $if (not exists) have been uploaded, and the Internet Archive has processed them. |] where - bucket = fromMaybe "" $ M.lookup "bucket" c + bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c #ifdef WITH_S3 url = S3.iaItemUrl bucket #else diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index faf3cde57e..a1f677d18b 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -39,6 +39,7 @@ import Utility.Gpg import qualified Remote.GCrypt as GCrypt import qualified Types.Remote import Utility.Android +import Types.ProposedAccepted import qualified Data.Text as T import qualified Data.Map as M @@ -325,7 +326,7 @@ getFinishAddDriveR drive = go makewith $ const $ do r <- liftAnnex $ addRemote $ enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList - [("gitrepo", dir)] + [(Proposed "gitrepo", Proposed dir)] return (u, r) {- Making a new unencrypted repo, or combining with an existing one. -} makeunencrypted = makewith $ \isnew -> (,) diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 9ed76bef48..002f9c2552 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -20,6 +20,7 @@ import Types.StandardGroups import Utility.UserInfo import Utility.Gpg import Types.Remote (RemoteConfig) +import Types.ProposedAccepted import Git.Types (RemoteName, fromRef, fromConfigKey) import qualified Remote.GCrypt as GCrypt import qualified Annex @@ -177,7 +178,7 @@ postEnableRsyncR = enableSshRemote getsshinput enableRsyncNet enablersync where enablersync sshdata u = redirect $ ConfirmSshR (sshdata { sshCapabilities = [RsyncCapable] }) u - getsshinput = parseSshUrl <=< M.lookup "rsyncurl" + getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "rsyncurl") {- This only handles gcrypt repositories that are located on ssh servers; - ones on local drives are handled via another part of the UI. -} @@ -191,7 +192,7 @@ postEnableSshGCryptR u = whenGcryptInstalled $ sshConfigurator $ checkExistingGCrypt sshdata' $ giveup "Expected to find an encrypted git repository, but did not." - getsshinput = parseSshUrl <=< M.lookup "gitrepo" + getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "gitrepo") getEnableSshGitRemoteR :: UUID -> Handler Html getEnableSshGitRemoteR = postEnableSshGitRemoteR @@ -200,7 +201,7 @@ postEnableSshGitRemoteR = enableSshRemote getsshinput enableRsyncNet enablesshgi where enablesshgitremote sshdata u = redirect $ ConfirmSshR sshdata u - getsshinput = parseSshUrl <=< M.lookup "location" + getsshinput = parseSshUrl . fromProposedAccepted <=< M.lookup (Accepted "location") {- To enable a remote that uses ssh as its transport, - parse a config key to get its url, and display a form @@ -424,7 +425,7 @@ getConfirmSshR sshdata u $(widgetFile "configurators/ssh/combine") handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do m <- liftAnnex readRemoteLog - case M.lookup "type" =<< M.lookup u m of + case fromProposedAccepted <$> (M.lookup typeField =<< M.lookup u m) of Just "gcrypt" -> combineExistingGCrypt sshdata' u _ -> makeSshRepo ExistingRepo sshdata' @@ -474,7 +475,7 @@ enableGCrypt :: SshData -> RemoteName -> Handler Html enableGCrypt sshdata reponame = setupRemote postsetup Nothing Nothing mk where mk = enableSpecialRemote reponame GCrypt.remote Nothing $ - M.fromList [("gitrepo", genSshUrl sshdata)] + M.fromList [(Proposed "gitrepo", Proposed (genSshUrl sshdata))] postsetup _ = redirect DashboardR {- Combining with a gcrypt repository that may not be @@ -546,11 +547,11 @@ makeSshRepo rs sshdata setup r = do m <- readRemoteLog let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m) - let c' = M.insert "location" (genSshUrl sshdata) $ - M.insert "type" "git" $ - case M.lookup nameField c of + let c' = M.insert (Proposed "location") (Proposed (genSshUrl sshdata)) $ + M.insert typeField (Proposed "git") $ + case fromProposedAccepted <$> M.lookup nameField c of Just _ -> c - Nothing -> M.insert nameField (Remote.name r) c + Nothing -> M.insert nameField (Proposed (Remote.name r)) c configSet (Remote.uuid r) c' makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index cec43e1a5f..97732752bd 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -22,6 +22,7 @@ import Git.Types (RemoteName) import Assistant.Gpg import Types.GitConfig import Annex.SpecialRemote.Config +import Types.ProposedAccepted import qualified Data.Map as M #endif @@ -58,7 +59,7 @@ postEnableWebDAVR uuid = do m <- liftAnnex readRemoteLog let c = fromJust $ M.lookup uuid m let name = fromJust $ lookupName c - let url = fromJust $ M.lookup "url" c + let url = fromProposedAccepted $ fromJust $ M.lookup (Accepted "url") c mcreds <- liftAnnex $ do dummycfg <- liftIO dummyRemoteGitConfig getRemoteCredPairFor "webdav" c dummycfg (WebDAV.davCreds uuid) diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs index 092557d578..f388dd77b9 100644 --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -26,6 +26,7 @@ import Assistant.Sync import Config.Cost import Utility.NotificationBroadcaster import qualified Git +import Types.ProposedAccepted import qualified Data.Map as M import qualified Data.Set as S @@ -175,7 +176,7 @@ repoList reposelector selectedremote (Just (iscloud, _)) | onlyCloud reposelector = iscloud | otherwise = True - findinfo m g u = case getconfig "type" of + findinfo m g u = case fromProposedAccepted <$> getconfig (Accepted "type") of Just "rsync" -> val True EnableRsyncR Just "directory" -> val False EnableDirectoryR #ifdef WITH_S3 @@ -188,12 +189,12 @@ repoList reposelector Just "gcrypt" -> -- Skip gcrypt repos on removable drives; -- handled separately. - case getconfig "gitrepo" of + case fromProposedAccepted <$> getconfig (Accepted "gitrepo") of Just rr | remoteLocationIsUrl (parseRemoteLocation rr g) -> val True EnableSshGCryptR _ -> Nothing Just "git" -> - case getconfig "location" of + case fromProposedAccepted <$> getconfig (Accepted "location") of Just loc | remoteLocationIsSshUrl (parseRemoteLocation loc g) -> val True EnableSshGitRemoteR _ -> Nothing diff --git a/CHANGELOG b/CHANGELOG index 64a822db59..dcfe3d2c81 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -5,6 +5,9 @@ git-annex (7.20191231) UNRELEASED; urgency=medium bugs like the smudge bug fixed in the last release). * reinject --known: Fix bug that prevented it from working in a bare repo. * Support being used in a git repository that uses sha256 rather than sha1. + * initremote, enableremote: Be stricter about rejecting invalid + configurations for remotes, particularly things like foo=true when + foo=yes is expected. -- Joey Hess Wed, 01 Jan 2020 12:51:40 -0400 diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index f43ab68f8b..9d5fc4b108 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -24,6 +24,7 @@ import Annex.UUID import Config import Config.DynamicConfig import Types.GitConfig +import Types.ProposedAccepted import qualified Data.Map as M @@ -41,7 +42,7 @@ start [] = unknownNameError "Specify the remote to enable." start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes where matchingname r = Git.remoteName r == Just name - go [] = startSpecialRemote name (Logs.Remote.keyValToConfig rest) + go [] = startSpecialRemote name (Logs.Remote.keyValToConfig Proposed rest) =<< SpecialRemote.findExisting name go (r:_) = do -- This could be either a normal git remote or a special diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 09aee869dc..5556a9ec0a 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -20,6 +20,7 @@ import Annex.UUID import Logs.UUID import Logs.Remote import Types.GitConfig +import Types.ProposedAccepted import Config cmd :: Command @@ -63,7 +64,7 @@ start o (name:ws) = ifM (isJust <$> findExisting name) (Just . Sameas <$$> getParsed) (sameas o) c <- newConfig name sameasuuid - (Logs.Remote.keyValToConfig ws) + (Logs.Remote.keyValToConfig Proposed ws) <$> readRemoteLog t <- either giveup return (findType c) starting "initremote" (ActionItemOther (Just name)) $ @@ -77,12 +78,12 @@ perform t name c o = do (c', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c dummycfg next $ cleanup u name c' o where - uuidfromuser = case M.lookup "uuid" c of + uuidfromuser = case fromProposedAccepted <$> M.lookup (Accepted "uuid") c of Just s | isUUID s -> Just (toUUID s) | otherwise -> giveup "invalid uuid" Nothing -> Nothing - sameasu = toUUID <$> M.lookup sameasUUIDField c + sameasu = toUUID . fromProposedAccepted <$> M.lookup sameasUUIDField c cleanup :: UUID -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup cleanup u name c o = do diff --git a/Command/RenameRemote.hs b/Command/RenameRemote.hs index 51e0127b0d..6860bacff4 100644 --- a/Command/RenameRemote.hs +++ b/Command/RenameRemote.hs @@ -13,6 +13,7 @@ import Annex.SpecialRemote.Config (nameField, sameasNameField) import qualified Logs.Remote import qualified Types.Remote as R import qualified Remote +import Types.ProposedAccepted import qualified Data.Map as M @@ -50,6 +51,6 @@ perform u cfg mcu newname = do let (namefield, cu) = case mcu of Nothing -> (nameField, u) Just (Annex.SpecialRemote.ConfigFrom u') -> (sameasNameField, u') - Logs.Remote.configSet cu (M.insert namefield newname cfg) + Logs.Remote.configSet cu (M.insert namefield (Proposed newname) cfg) next $ return True diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index bf8c24cd5d..b18c145f43 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -24,6 +24,7 @@ import Utility.DataUnits import Utility.CopyFile import Types.Messages import Types.Export +import Types.ProposedAccepted import Remote.Helper.ExportImport import Remote.Helper.Chunked import Git.Types @@ -109,7 +110,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", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))] + , ["encryption", maybe "none" fromProposedAccepted (M.lookup (Accepted "encryption") (Remote.config r'))] ] descexport k1 k2 = intercalate "; " $ map unwords [ [ "exporttree=yes" ] @@ -119,28 +120,29 @@ perform rs unavailrs exportr ks = do adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) adjustChunkSize r chunksize = adjustRemoteConfig r - (M.insert "chunk" (show chunksize)) + (M.insert (Proposed "chunk") (Proposed (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 "encryption" "none") + noenc <- adjustRemoteConfig r (M.insert (Proposed "encryption") (Proposed "none")) sharedenc <- adjustRemoteConfig r $ - M.insert "encryption" "shared" . - M.insert "highRandomQuality" "false" + M.insert (Proposed "encryption") (Proposed "shared") . + M.insert (Proposed "highRandomQuality") (Proposed "false") return $ catMaybes [noenc, sharedenc] -- Variant of a remote with exporttree disabled. disableExportTree :: Remote -> Annex Remote disableExportTree r = maybe (error "failed disabling exportree") return - =<< adjustRemoteConfig r (M.delete "exporttree") + =<< adjustRemoteConfig r (M.delete (Accepted "exporttree")) -- Variant of a remote with exporttree enabled. exportTreeVariant :: Remote -> Annex (Maybe Remote) exportTreeVariant r = ifM (Remote.isExportSupported r) ( adjustRemoteConfig r $ - M.insert "encryption" "none" . M.insert "exporttree" "yes" + M.insert (Proposed "encryption") (Proposed "none") . + M.insert (Proposed "exporttree") (Proposed "yes") , return Nothing ) diff --git a/Config.hs b/Config.hs index 68c657aa47..75f313137e 100644 --- a/Config.hs +++ b/Config.hs @@ -21,6 +21,7 @@ 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 @@ -97,12 +98,6 @@ setRemoteIgnore r b = setConfig (remoteConfig r "ignore") (Git.Config.boolConfig setRemoteBare :: Git.Repo -> Bool -> Annex () setRemoteBare r b = setConfig (remoteConfig r "bare") (Git.Config.boolConfig b) -exportTree :: Remote.RemoteConfig -> Bool -exportTree c = fromMaybe False $ yesNo =<< M.lookup "exporttree" c - -importTree :: Remote.RemoteConfig -> Bool -importTree c = fromMaybe False $ yesNo =<< M.lookup "importtree" c - isBareRepo :: Annex Bool isBareRepo = fromRepo Git.repoIsLocalBare @@ -117,6 +112,14 @@ 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/Creds.hs b/Creds.hs index 3531060d09..88ce1aba51 100644 --- a/Creds.hs +++ b/Creds.hs @@ -27,6 +27,7 @@ import Annex.Perms import Utility.FileMode import Crypto import Types.Remote (RemoteConfig, RemoteConfigField) +import Types.ProposedAccepted import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher) import Utility.Env (getEnv) @@ -71,9 +72,9 @@ setRemoteCredPair encsetup c gc storage mcreds = case mcreds of s <- liftIO $ encrypt cmd (c, gc) cipher (feedBytes $ L.pack $ encodeCredPair creds) (readBytes $ return . L.unpack) - return $ M.insert key (toB64 s) c + return $ M.insert key (Accepted (toB64 s)) c storeconfig creds key Nothing = - return $ M.insert key (toB64 $ encodeCredPair creds) c + return $ M.insert key (Accepted (toB64 $ encodeCredPair creds)) c {- Gets a remote's credpair, from the environment if set, otherwise - from the cache in gitAnnexCredsDir, or failing that, from the @@ -86,7 +87,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv fromconfig = do let key = credPairRemoteField storage mcipher <- remoteCipher' c gc - case (M.lookup key c, mcipher) of + case (fromProposedAccepted <$> M.lookup key c, mcipher) of (Nothing, _) -> return Nothing (Just enccreds, Just (cipher, storablecipher)) -> fromenccreds enccreds cipher storablecipher diff --git a/Crypto.hs b/Crypto.hs index 08aef47cd5..655911af78 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -45,6 +45,7 @@ import qualified Utility.Gpg as Gpg import Types.Crypto import Types.Remote import Types.Key +import Types.ProposedAccepted import Annex.SpecialRemote.Config {- The beginning of a Cipher is used for MAC'ing; the remainder is used @@ -237,9 +238,9 @@ instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++ {- When the remote is configured to use public-key encryption, - look up the recipient keys and add them to the option list. -} - case M.lookup encryptionField c of - Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup cipherkeysField c - Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',') $ M.lookup pubkeysField c + case fromProposedAccepted <$> M.lookup encryptionField c of + Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',' . fromProposedAccepted) $ M.lookup cipherkeysField c + Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',' . fromProposedAccepted) $ M.lookup pubkeysField c _ -> [] getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc) diff --git a/Logs/Remote/Pure.hs b/Logs/Remote/Pure.hs index e855d87200..7d05269be6 100644 --- a/Logs/Remote/Pure.hs +++ b/Logs/Remote/Pure.hs @@ -19,6 +19,7 @@ module Logs.Remote.Pure ( import Annex.Common import Types.Remote +import Types.ProposedAccepted import Logs.UUIDBased import Annex.SpecialRemote.Config @@ -40,24 +41,24 @@ buildRemoteConfigLog :: Log RemoteConfig -> Builder buildRemoteConfigLog = buildLogOld (byteString . encodeBS . showConfig) remoteConfigParser :: A.Parser RemoteConfig -remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString +remoteConfigParser = keyValToConfig Accepted . words . decodeBS <$> A.takeByteString showConfig :: RemoteConfig -> String showConfig = unwords . configToKeyVal {- Given Strings like "key=value", generates a RemoteConfig. -} -keyValToConfig :: [String] -> RemoteConfig -keyValToConfig ws = M.fromList $ map (/=/) ws +keyValToConfig :: (String -> ProposedAccepted String) -> [String] -> RemoteConfig +keyValToConfig mk ws = M.fromList $ map (/=/) ws where - (/=/) s = (k, v) + (/=/) s = (mk k, mk v) where k = takeWhile (/= '=') s v = configUnEscape $ drop (1 + length k) s -configToKeyVal :: M.Map String String -> [String] +configToKeyVal :: RemoteConfig -> [String] configToKeyVal m = map toword $ sort $ M.toList m where - toword (k, v) = k ++ "=" ++ configEscape v + toword (k, v) = fromProposedAccepted k ++ "=" ++ configEscape (fromProposedAccepted v) configEscape :: String -> String configEscape = concatMap escape @@ -90,9 +91,9 @@ prop_isomorphic_configEscape s = s == (configUnEscape . configEscape) s prop_parse_show_Config :: RemoteConfig -> Bool prop_parse_show_Config c -- whitespace and '=' are not supported in config keys - | any (\k -> any isSpace k || elem '=' k) (M.keys c) = True - | any (any excluded) (M.keys c) = True - | any (any excluded) (M.elems c) = True + | any (\k -> any isSpace k || elem '=' k) (map fromProposedAccepted $ M.keys c) = True + | any (any excluded) (map fromProposedAccepted $ M.keys c) = True + | any (any excluded) (map fromProposedAccepted $ M.elems c) = True | otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c where normalize v = sort . M.toList <$> v diff --git a/Remote/Adb.hs b/Remote/Adb.hs index e7e8fae3b9..4080ed61ad 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -19,6 +19,7 @@ import Remote.Helper.Messages import Remote.Helper.ExportImport import Annex.UUID import Utility.Metered +import Types.ProposedAccepted import qualified Data.Map as M import qualified System.FilePath.Posix as Posix @@ -109,10 +110,12 @@ adbSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration - adir <- maybe (giveup "Specify androiddirectory=") (pure . AndroidPath) - (M.lookup "androiddirectory" c) + adir <- maybe + (giveup "Specify androiddirectory=") + (pure . AndroidPath . fromProposedAccepted) + (M.lookup (Accepted "androiddirectory") c) serial <- getserial =<< liftIO enumerateAdbConnected - let c' = M.insert "androidserial" (fromAndroidSerial serial) c + let c' = M.insert (Proposed "androidserial") (Proposed (fromAndroidSerial serial)) c (c'', _encsetup) <- encryptionSetup c' gc @@ -130,7 +133,7 @@ adbSetup _ mu _ c gc = do return (c'', u) where getserial [] = giveup "adb does not list any connected android devices. Plug in an Android device, or configure adb, and try again.." - getserial l = case M.lookup "androidserial" c of + getserial l = case fromProposedAccepted <$> M.lookup (Accepted "androidserial") c of Nothing -> case l of (s:[]) -> return s _ -> giveup $ unlines $ diff --git a/Remote/Bup.hs b/Remote/Bup.hs index b1ba5f1870..a283fe07f1 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -33,6 +33,7 @@ import Utility.UserInfo import Annex.UUID import Annex.Ssh import Utility.Metered +import Types.ProposedAccepted type BupRepo = String @@ -108,8 +109,8 @@ bupSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let buprepo = fromMaybe (giveup "Specify buprepo=") $ - M.lookup "buprepo" c + let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $ + M.lookup (Accepted "buprepo") c (c', _encsetup) <- encryptionSetup c gc -- bup init will create the repository. diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index f34d045f61..96e9364524 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -23,6 +23,7 @@ import Remote.Helper.ExportImport import Annex.Ssh import Annex.UUID import Utility.SshHost +import Types.ProposedAccepted data DdarRepo = DdarRepo { ddarRepoConfig :: RemoteGitConfig @@ -98,8 +99,8 @@ ddarSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let ddarrepo = fromMaybe (giveup "Specify ddarrepo=") $ - M.lookup "ddarrepo" c + let ddarrepo = maybe (giveup "Specify ddarrepo=") fromProposedAccepted $ + M.lookup (Accepted "ddarrepo") c (c', _encsetup) <- encryptionSetup c gc -- The ddarrepo is stored in git config, as well as this repo's diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 3aa6185155..56cf567515 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -34,6 +34,7 @@ import Annex.UUID import Utility.Metered import Utility.Tmp import Utility.InodeCache +import Types.ProposedAccepted remote :: RemoteType remote = RemoteType @@ -111,8 +112,8 @@ directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> directorySetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let dir = fromMaybe (giveup "Specify directory=") $ - M.lookup "directory" c + let dir = maybe (giveup "Specify directory=") fromProposedAccepted $ + M.lookup (Accepted "directory") c absdir <- liftIO $ absPath dir liftIO $ unlessM (doesDirectoryExist absdir) $ giveup $ "Directory does not exist: " ++ absdir @@ -121,7 +122,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 "directory" c', u) + return (M.delete (Accepted "directory") 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/External.hs b/Remote/External.hs index 016000badb..501feb8e3a 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -16,6 +16,7 @@ import Types.Remote import Types.Export import Types.CleanupActions import Types.UrlContents +import Types.ProposedAccepted import qualified Git import Config import Git.Config (isTrueFalse, boolConfig) @@ -152,12 +153,13 @@ gen r u c gc rs externalSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) externalSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu - let externaltype = fromMaybe (giveup "Specify externaltype=") $ - M.lookup "externaltype" c + let externaltype = maybe (giveup "Specify externaltype=") fromProposedAccepted $ + M.lookup (Accepted "externaltype") c (c', _encsetup) <- encryptionSetup c gc - c'' <- case M.lookup "readonly" c of - Just v | isTrueFalse v == Just True -> do + c'' <- case parseProposedAccepted (Accepted "readonly") c isTrueFalse False "true or false" of + Left err -> giveup err + Right (Just True) -> do setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True) return c' _ -> do @@ -175,7 +177,7 @@ externalSetup _ mu _ c gc = do checkExportSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool checkExportSupported c gc = do let externaltype = fromMaybe (giveup "Specify externaltype=") $ - remoteAnnexExternalType gc <|> M.lookup "externaltype" c + remoteAnnexExternalType gc <|> (fromProposedAccepted <$> M.lookup (Accepted "externaltype") c) checkExportSupported' =<< newExternal externaltype NoUUID c gc Nothing @@ -388,9 +390,9 @@ handleRequest' st external req mp responsehandler send $ VALUE $ fromRawFilePath $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) = liftIO $ atomically $ modifyTVar' (externalConfig st) $ - M.insert setting value + M.insert (Accepted setting) (Accepted value) handleRemoteRequest (GETCONFIG setting) = do - value <- fromMaybe "" . M.lookup setting + value <- maybe "" fromProposedAccepted . M.lookup (Accepted setting) <$> liftIO (atomically $ readTVar $ externalConfig st) send $ VALUE value handleRemoteRequest (SETCREDS setting login password) = do @@ -451,7 +453,7 @@ handleRequest' st external req mp responsehandler credstorage setting = CredPairStorage { credPairFile = base , credPairEnvironment = (base ++ "login", base ++ "password") - , credPairRemoteField = setting + , credPairRemoteField = Accepted setting } where base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 9fa5916978..4952d2f0a1 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -56,6 +56,7 @@ import Logs.Remote import Utility.Gpg import Utility.SshHost import Messages.Progress +import Types.ProposedAccepted remote :: RemoteType remote = RemoteType @@ -187,7 +188,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 $ M.lookup "gitrepo" c +gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup (Accepted "gitrepo") c where remotename = fromJust (lookupName c) go Nothing = giveup "Specify gitrepo=" diff --git a/Remote/Git.hs b/Remote/Git.hs index 3a7bb48446..037344d958 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -59,6 +59,7 @@ import P2P.Address import Annex.Path import Creds import Types.NumCopies +import Types.ProposedAccepted import Annex.Action import Messages.Progress @@ -111,7 +112,8 @@ list autoinit = do gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) gitSetup Init mu _ c _ = do let location = fromMaybe (giveup "Specify location=url") $ - Url.parseURIRelaxed =<< M.lookup "location" c + Url.parseURIRelaxed . fromProposedAccepted + =<< M.lookup (Accepted "location") c rs <- Annex.getGitRemotes u <- case filter (\r -> Git.location r == Git.Url location) rs of [r] -> getRepoUUID r @@ -125,7 +127,7 @@ gitSetup (Enable _) (Just u) _ c _ = do [ Param "remote" , Param "add" , Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c) - , Param $ fromMaybe (giveup "no location") (M.lookup "location" c) + , Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup (Accepted "location") c) ] return (c, u) gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid" diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index fb4f2fce8c..d6f94e2fc2 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -14,6 +14,7 @@ import Types.Remote import Annex.Url import Types.Key import Types.Creds +import Types.ProposedAccepted import qualified Annex import qualified Annex.SpecialRemote.Config import qualified Git @@ -158,7 +159,8 @@ mySetup _ mu _ c gc = do setConfig (Git.ConfigKey ("remote." <> encodeBS' (getRemoteName c) <> ".url")) url return (c', u) where - url = fromMaybe (giveup "Specify url=") (M.lookup "url" c) + url = maybe (giveup "Specify url=") fromProposedAccepted + (M.lookup (Accepted "url") c) remotename = fromJust (lookupName c) {- Check if a remote's url is one known to belong to a git-lfs repository. @@ -175,8 +177,10 @@ configKnownUrl r | otherwise = return Nothing where match g c = fromMaybe False $ do - t <- M.lookup Annex.SpecialRemote.Config.typeField c - u <- M.lookup "url" c + t <- fromProposedAccepted + <$> M.lookup Annex.SpecialRemote.Config.typeField c + u <- fromProposedAccepted + <$> M.lookup (Accepted "url") c let u' = Git.Remote.parseRemoteLocation u g return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u' && t == typename remote diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 00d623f50f..6f5af226e5 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -25,6 +25,7 @@ import Utility.Metered import qualified Annex import Annex.UUID import Utility.Env +import Types.ProposedAccepted type Vault = String type Archive = FilePath @@ -108,8 +109,8 @@ glacierSetup' ss u mcreds c gc = do remotename = fromJust (lookupName c) defvault = remotename ++ "-" ++ fromUUID u defaults = M.fromList - [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.Glacier) - , ("vault", defvault) + [ (Proposed "datacenter", Proposed $ T.unpack $ AWS.defaultRegion AWS.Glacier) + , (Proposed "vault", Proposed defvault) ] prepareStore :: Remote -> Preparer Storer @@ -235,8 +236,8 @@ glacierParams :: RemoteConfig -> [CommandParam] -> [CommandParam] glacierParams c params = datacenter:params where datacenter = Param $ "--region=" ++ - fromMaybe (giveup "Missing datacenter configuration") - (M.lookup "datacenter" c) + maybe (giveup "Missing datacenter configuration") fromProposedAccepted + (M.lookup (Accepted "datacenter") c) glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)]) glacierEnv c gc u = do @@ -252,13 +253,14 @@ glacierEnv c gc u = do (uk, pk) = credPairEnvironment creds getVault :: RemoteConfig -> Vault -getVault = fromMaybe (giveup "Missing vault configuration") - . M.lookup "vault" +getVault = maybe (giveup "Missing vault configuration") fromProposedAccepted + . M.lookup (Accepted "vault") archive :: Remote -> Key -> Archive archive r k = fileprefix ++ serializeKey k where - fileprefix = M.findWithDefault "" "fileprefix" $ config r + fileprefix = maybe "" fromProposedAccepted $ + M.lookup (Accepted "fileprefix") $ config r genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex () genVault c gc u = unlessM (runGlacier c gc u params) $ diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs index 3ab2063e4b..759de1972b 100644 --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -12,6 +12,7 @@ module Remote.Helper.AWS where import Annex.Common import Creds +import Types.ProposedAccepted import qualified Data.Map as M import qualified Data.ByteString as B @@ -23,7 +24,7 @@ creds :: UUID -> CredPairStorage creds u = CredPairStorage { credPairFile = fromUUID u , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") - , credPairRemoteField = "s3creds" + , credPairRemoteField = Accepted "s3creds" } data Service = S3 | Glacier diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 473760edb3..da79d34113 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -21,6 +21,7 @@ import Annex.Common import Utility.DataUnits import Types.StoreRetrieve import Types.Remote +import Types.ProposedAccepted import Logs.Chunk import Utility.Metered import Crypto (EncKey) @@ -51,16 +52,16 @@ noChunks _ = False getChunkConfig :: RemoteConfig -> ChunkConfig getChunkConfig m = case M.lookup chunksizeField m of - Nothing -> case M.lookup "chunk" m of + Nothing -> case M.lookup (Accepted "chunk") m of Nothing -> NoChunks - Just v -> readsz UnpaddedChunks v "chunk" - Just v -> readsz LegacyChunks v chunksizeField + Just v -> readsz UnpaddedChunks (fromProposedAccepted v) (Accepted "chunk") + Just v -> readsz LegacyChunks (fromProposedAccepted v) chunksizeField where readsz c v f = case readSize dataUnits v of Just size | size == 0 -> NoChunks | size > 0 -> c (fromInteger size) - _ -> giveup $ "bad configuration " ++ f ++ "=" ++ v + _ -> giveup $ "bad configuration " ++ fromProposedAccepted f ++ "=" ++ v -- An infinite stream of chunk keys, starting from chunk 1. newtype ChunkKeyStream = ChunkKeyStream [Key] diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 42df0e41bc..82e48474c8 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -28,6 +28,7 @@ import Types.Remote import Config import Crypto import Types.Crypto +import Types.ProposedAccepted import qualified Annex import Annex.SpecialRemote.Config @@ -56,7 +57,7 @@ encryptionSetup c gc = do maybe (genCipher cmd) (updateCipher cmd) (extractCipher c) where -- The type of encryption - encryption = M.lookup encryptionField c + encryption = fromProposedAccepted <$> M.lookup encryptionField c -- Generate a new cipher, depending on the chosen encryption scheme genCipher cmd = case encryption of _ | hasEncryptionConfig c -> cannotchange @@ -64,17 +65,18 @@ encryptionSetup c gc = do Just "shared" -> encsetup $ genSharedCipher cmd -- hybrid encryption is the default when a keyid is -- specified but no encryption - _ | maybe (M.member "keyid" c) (== "hybrid") encryption -> + _ | maybe (M.member (Accepted "keyid") c) (== "hybrid") encryption -> encsetup $ genEncryptedCipher cmd (c, gc) key Hybrid Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key _ -> giveup $ "Specify " ++ intercalate " or " - (map ((encryptionField ++ "=") ++) + (map ((fromProposedAccepted encryptionField ++ "=") ++) ["none","shared","hybrid","pubkey", "sharedpubkey"]) ++ "." - key = fromMaybe (giveup "Specify keyid=...") $ M.lookup "keyid" c - newkeys = maybe [] (\k -> [(True,k)]) (M.lookup "keyid+" c) ++ - maybe [] (\k -> [(False,k)]) (M.lookup "keyid-" c) + key = maybe (giveup "Specify keyid=...") fromProposedAccepted $ + M.lookup (Accepted "keyid") c + newkeys = maybe [] (\k -> [(True,fromProposedAccepted k)]) (M.lookup (Accepted "keyid+") c) ++ + maybe [] (\k -> [(False,fromProposedAccepted k)]) (M.lookup (Accepted "keyid-") c) cannotchange = giveup "Cannot set encryption type of existing remotes." -- Update an existing cipher if possible. updateCipher cmd v = case v of @@ -92,14 +94,14 @@ encryptionSetup c gc = do showNote (describeCipher cipher) return (storeCipher cipher c', EncryptionIsSetup) highRandomQuality = - (&&) (maybe True ( /= "false") $ M.lookup "highRandomQuality" c) + (&&) (maybe True (\v -> fromProposedAccepted v /= "false") $ M.lookup (Accepted "highRandomQuality") c) <$> fmap not (Annex.getState Annex.fast) c' = foldr M.delete c -- git-annex used to remove 'encryption' as well, since -- it was redundant; we now need to keep it for -- public-key encryption, hence we leave it on newer -- remotes (while being backward-compatible). - [ "keyid", "keyid+", "keyid-", "highRandomQuality" ] + (map Accepted [ "keyid", "keyid+", "keyid-", "highRandomQuality" ]) remoteCipher :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher) remoteCipher c gc = fmap fst <$> remoteCipher' c gc @@ -129,7 +131,7 @@ remoteCipher' c gc = go $ extractCipher c - Not when a shared cipher is used. -} embedCreds :: RemoteConfig -> Bool -embedCreds c = case yesNo =<< M.lookup "embedcreds" c of +embedCreds c = case yesNo . fromProposedAccepted =<< M.lookup embedCredsField c of Just v -> v Nothing -> isJust (M.lookup cipherkeysField c) && isJust (M.lookup cipherField c) @@ -138,7 +140,8 @@ cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey)) cipherKey c gc = fmap make <$> remoteCipher c gc where make ciphertext = (ciphertext, encryptKey mac ciphertext) - mac = fromMaybe defaultMac $ M.lookup macField c >>= readMac + mac = fromMaybe defaultMac $ + M.lookup macField c >>= readMac . fromProposedAccepted {- Stores an StorableCipher in a remote's configuration. -} storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig @@ -147,14 +150,14 @@ storeCipher cip = case cip of (EncryptedCipher t _ ks) -> addcipher t . storekeys ks cipherkeysField (SharedPubKeyCipher t ks) -> addcipher t . storekeys ks pubkeysField where - addcipher t = M.insert cipherField (toB64bs t) - storekeys (KeyIds l) n = M.insert n (intercalate "," l) + addcipher t = M.insert cipherField (Accepted (toB64bs t)) + storekeys (KeyIds l) n = M.insert n (Accepted (intercalate "," l)) {- Extracts an StorableCipher from a remote's configuration. -} extractCipher :: RemoteConfig -> Maybe StorableCipher -extractCipher c = case (M.lookup cipherField c, - M.lookup cipherkeysField c <|> M.lookup pubkeysField c, - M.lookup encryptionField c) of +extractCipher c = case (fromProposedAccepted <$> M.lookup cipherField c, + fromProposedAccepted <$> (M.lookup cipherkeysField c <|> M.lookup pubkeysField c), + fromProposedAccepted <$> M.lookup encryptionField c) of (Just t, Just ks, encryption) | maybe True (== "hybrid") encryption -> Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks) (Just t, Just ks, Just "pubkey") -> @@ -168,7 +171,7 @@ extractCipher c = case (M.lookup cipherField c, readkeys = KeyIds . splitc ',' isEncrypted :: RemoteConfig -> Bool -isEncrypted c = case M.lookup encryptionField c of +isEncrypted c = case fromProposedAccepted <$> M.lookup encryptionField c of Just "none" -> False Just _ -> True Nothing -> hasEncryptionConfig c diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 21d9814c65..2af981e545 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -13,6 +13,7 @@ import Annex.Common import Types.Remote import Types.Backend import Types.Key +import Types.ProposedAccepted import Backend import Remote.Helper.Encryptable (isEncrypted) import qualified Database.Export as Export @@ -20,6 +21,7 @@ import qualified Database.ContentIdentifier as ContentIdentifier import Annex.Export import Annex.LockFile import Config +import Annex.SpecialRemote.Config (exportTreeField, importTreeField) import Git.Types (fromRef) import Logs.Export import Logs.ContentIdentifier (recordContentIdentifier) @@ -75,23 +77,26 @@ adjustExportImportRemoteType :: RemoteType -> RemoteType adjustExportImportRemoteType rt = rt { setup = setup' } where setup' st mu cp c gc = - let checkconfig supported configured setting cont = + 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) ( case st of Init | configured c && isEncrypted c -> - giveup $ "cannot enable both encryption and " ++ setting + giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield | otherwise -> cont Enable oldc | configured c /= configured oldc -> - giveup $ "cannot change " ++ setting ++ " of existing special remote" + giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote" | otherwise -> cont , if configured c - then giveup $ setting ++ " is not supported by this special remote" + then giveup $ fromProposedAccepted configfield ++ " is not supported by this special remote" else cont ) - in checkconfig exportSupported exportTree "exporttree" $ - checkconfig importSupported importTree "importtree" $ + in checkconfig exportSupported exportTree exportTreeField $ + checkconfig importSupported importTree importTreeField $ 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 @@ -100,9 +105,9 @@ adjustExportImportRemoteType rt = rt { setup = setup' } -- -- Note that all remotes with importree=yes also have exporttree=yes. adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote -adjustExportImport r rs = case M.lookup "exporttree" (config r) of +adjustExportImport r rs = case M.lookup exportTreeField (config r) of Nothing -> return $ notexport r - Just c -> case yesNo c of + Just c -> case yesNo (fromProposedAccepted c) of Just True -> ifM (isExportSupported r) ( do exportdbv <- prepexportdb diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 897e73cc1f..f3ef2a8cfe 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -20,6 +20,7 @@ import Remote.Helper.Messages import Remote.Helper.ExportImport import Utility.Env import Messages.Progress +import Types.ProposedAccepted import qualified Data.Map as M @@ -85,8 +86,8 @@ gen r u c gc rs = do hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) hookSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu - let hooktype = fromMaybe (giveup "Specify hooktype=") $ - M.lookup "hooktype" c + let hooktype = maybe (giveup "Specify hooktype=") fromProposedAccepted $ + M.lookup (Accepted "hooktype") c (c', _encsetup) <- encryptionSetup c gc gitConfigSpecialRemote u c' [("hooktype", hooktype)] return (c', u) diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 1847514002..8b331503b9 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -30,6 +30,7 @@ import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.ExportImport import Types.Export +import Types.ProposedAccepted import Remote.Rsync.RsyncUrl import Crypto import Utility.Rsync @@ -119,7 +120,7 @@ genRsyncOpts c gc transport url = RsyncOpts opts (remoteAnnexRsyncUploadOptions gc) , rsyncDownloadOptions = appendtransport $ opts (remoteAnnexRsyncDownloadOptions gc) - , rsyncShellEscape = (yesNo =<< M.lookup "shellescape" c) /= Just False + , rsyncShellEscape = (yesNo . fromProposedAccepted =<< M.lookup (Accepted "shellescape") c) /= Just False } where appendtransport l = (++ l) <$> transport @@ -161,8 +162,11 @@ rsyncSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remo rsyncSetup _ mu _ c gc = do u <- maybe (liftIO genUUID) return mu -- verify configuration is sane - let url = fromMaybe (giveup "Specify rsyncurl=") $ - M.lookup "rsyncurl" c + 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 (c', _encsetup) <- encryptionSetup c gc -- The rsyncurl is stored in git config, not only in this remote's diff --git a/Remote/S3.hs b/Remote/S3.hs index 55d0b85fde..0b118f61ba 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -57,6 +57,7 @@ import Annex.Magic import Logs.Web import Logs.MetaData import Types.MetaData +import Types.ProposedAccepted import Utility.Metered import Utility.DataUnits import Annex.Content @@ -134,7 +135,7 @@ gen r u c gc rs = do , appendonly = versioning info , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc rs + , mkUnavailable = gen r u (M.insert (Accepted "host") (Accepted "!dne!") c) gc rs , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info) , claimUrl = Nothing , checkUrl = Nothing @@ -154,19 +155,27 @@ s3Setup' ss u mcreds c gc remotename = fromJust (lookupName c) defbucket = remotename ++ "-" ++ fromUUID u defaults = M.fromList - [ ("datacenter", T.unpack $ AWS.defaultRegion AWS.S3) - , ("storageclass", "STANDARD") - , ("host", AWS.s3DefaultHost) - , ("port", "80") - , ("bucket", defbucket) + [ (Proposed "datacenter", Proposed $ T.unpack $ AWS.defaultRegion AWS.S3) + , (Proposed "storageclass", Proposed "STANDARD") + , (Proposed "host", Proposed AWS.s3DefaultHost) + , (Proposed "port", Proposed "80") + , (Proposed "bucket", Proposed defbucket) ] - + + checkconfigsane = do + checkyesno "versioning" + checkyesno "public" + checkyesno k = case parseProposedAccepted (Accepted k) c yesNo False "yes or no" of + Left err -> giveup err + Right _ -> noop + use fullconfig info = do enableBucketVersioning ss info fullconfig gc u gitConfigSpecialRemote u fullconfig [("s3", "true")] return (fullconfig, u) defaulthost = do + checkconfigsane (c', encsetup) <- encryptionSetup c gc c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds let fullconfig = c'' `M.union` defaults @@ -179,21 +188,22 @@ s3Setup' ss u mcreds c gc archiveorg = do showNote "Internet Archive mode" + checkconfigsane c' <- setRemoteCredPair noEncryptionUsed c gc (AWS.creds u) mcreds -- Ensure user enters a valid bucket name, since -- this determines the name of the archive.org item. let validbucket = replace " " "-" $ - fromMaybe (giveup "specify bucket=") $ - getBucketName c' + fromMaybe (giveup "specify bucket=") + (getBucketName c') let archiveconfig = -- IA acdepts x-amz-* as an alias for x-archive-* - M.mapKeys (replace "x-archive-" "x-amz-") $ + M.mapKeys (Proposed . replace "x-archive-" "x-amz-" . fromProposedAccepted) $ -- encryption does not make sense here - M.insert encryptionField "none" $ - M.insert "bucket" validbucket $ + M.insert encryptionField (Proposed "none") $ + M.insert (Accepted "bucket") (Proposed validbucket) $ M.union c' $ -- special constraints on key names - M.insert "mungekeys" "ia" defaults + M.insert (Proposed "mungekeys") (Proposed "ia") defaults info <- extractS3Info archiveconfig checkexportimportsafe archiveconfig info hdl <- mkS3HandleVar archiveconfig gc u @@ -652,7 +662,8 @@ genBucket c gc u = do writeUUIDFile c u info h locconstraint = mkLocationConstraint $ T.pack datacenter - datacenter = fromJust $ M.lookup "datacenter" c + datacenter = fromProposedAccepted $ fromJust $ + M.lookup (Accepted "datacenter") c -- "NEARLINE" as a storage class when creating a bucket is a -- nonstandard extension of Google Cloud Storage. storageclass = case getStorageClass c of @@ -758,21 +769,23 @@ needS3Creds u = missingCredPairFor "S3" (AWS.creds u) s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery s3Configuration c = cfg { S3.s3Port = port - , S3.s3RequestStyle = case M.lookup "requeststyle" c of + , S3.s3RequestStyle = case fromProposedAccepted <$> M.lookup (Accepted "requeststyle") c of Just "path" -> S3.PathStyle Just s -> giveup $ "bad S3 requeststyle value: " ++ s Nothing -> S3.s3RequestStyle cfg } where - h = fromJust $ M.lookup "host" c - datacenter = fromJust $ M.lookup "datacenter" c + h = fromProposedAccepted $ fromJust $ + M.lookup (Accepted "host") c + datacenter = fromProposedAccepted $ fromJust $ + M.lookup (Accepted "datacenter") c -- When the default S3 host is configured, connect directly to -- the S3 endpoint for the configured datacenter. -- When another host is configured, it's used as-is. endpoint | h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter | otherwise = T.encodeUtf8 $ T.pack h - port = case M.lookup "port" c of + port = case fromProposedAccepted <$> M.lookup (Accepted "port") c of Just s -> case reads s of [(p, _)] @@ -787,7 +800,7 @@ s3Configuration c = cfg Just AWS.HTTPS -> 443 Just AWS.HTTP -> 80 Nothing -> 80 - cfgproto = case M.lookup "protocol" c of + cfgproto = case fromProposedAccepted <$> M.lookup (Accepted "protocol") c of Just "https" -> Just AWS.HTTPS Just "http" -> Just AWS.HTTP Just s -> giveup $ "bad S3 protocol value: " ++ s @@ -831,11 +844,12 @@ extractS3Info c = do , isIA = configIA c , versioning = boolcfg "versioning" , public = boolcfg "public" - , publicurl = M.lookup "publicurl" c - , host = M.lookup "host" c + , publicurl = fromProposedAccepted <$> M.lookup (Accepted "publicurl") c + , host = fromProposedAccepted <$> M.lookup (Accepted "host") c } where - boolcfg k = fromMaybe False $ yesNo =<< M.lookup k c + boolcfg k = fromMaybe False $ + yesNo . fromProposedAccepted =<< M.lookup (Accepted k) c putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject putObject info file rbody = (S3.putObject (bucket info) file rbody) @@ -851,32 +865,36 @@ acl info | otherwise = Nothing getBucketName :: RemoteConfig -> Maybe BucketName -getBucketName = map toLower <$$> M.lookup "bucket" +getBucketName = map toLower . fromProposedAccepted + <$$> M.lookup (Accepted "bucket") getStorageClass :: RemoteConfig -> S3.StorageClass -getStorageClass c = case M.lookup "storageclass" c of +getStorageClass c = case fromProposedAccepted <$> M.lookup (Accepted "storageclass") c of Just "REDUCED_REDUNDANCY" -> S3.ReducedRedundancy Just s -> S3.OtherStorageClass (T.pack s) _ -> S3.Standard getPartSize :: RemoteConfig -> Maybe Integer -getPartSize c = readSize dataUnits =<< M.lookup "partsize" c +getPartSize c = readSize dataUnits . fromProposedAccepted + =<< M.lookup (Accepted "partsize") c getMetaHeaders :: RemoteConfig -> [(T.Text, T.Text)] -getMetaHeaders = map munge . filter ismetaheader . M.assocs +getMetaHeaders = map munge . filter ismetaheader . map unwrap . M.assocs where + unwrap (k, v) = (fromProposedAccepted k, fromProposedAccepted v) ismetaheader (h, _) = metaprefix `isPrefixOf` h metaprefix = "x-amz-meta-" metaprefixlen = length metaprefix munge (k, v) = (T.pack $ drop metaprefixlen k, T.pack v) getFilePrefix :: RemoteConfig -> String -getFilePrefix = M.findWithDefault "" "fileprefix" +getFilePrefix = maybe "" fromProposedAccepted + <$> M.lookup (Accepted "fileprefix") getBucketObject :: RemoteConfig -> Key -> BucketObject getBucketObject c = munge . serializeKey where - munge s = case M.lookup "mungekeys" c of + munge s = case fromProposedAccepted <$> M.lookup (Accepted "mungekeys") c of Just "ia" -> iaMunge $ getFilePrefix c ++ s _ -> getFilePrefix c ++ s @@ -911,7 +929,8 @@ iaMunge = (>>= munge) | otherwise = "&" ++ show (ord c) ++ ";" configIA :: RemoteConfig -> Bool -configIA = maybe False isIAHost . M.lookup "host" +configIA = maybe False (isIAHost . fromProposedAccepted) + . M.lookup (Accepted "host") {- Hostname to use for archive.org S3. -} iaHost :: HostName diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index b169a380f4..bbb40e80d7 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -30,9 +30,11 @@ import Control.Concurrent.STM import Annex.Common import Types.Remote import Types.Creds +import Types.ProposedAccepted import qualified Git import Config import Config.Cost +import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Annex.UUID @@ -102,22 +104,26 @@ gen r u c gc rs = do tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) tahoeSetup _ mu _ c _ = do - furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c) + furl <- maybe (fromMaybe missingfurl $ M.lookup furlk c) Proposed <$> liftIO (getEnv "TAHOE_FURL") u <- maybe (liftIO genUUID) return mu configdir <- liftIO $ defaultTahoeConfigDir u - scs <- liftIO $ tahoeConfigure configdir furl (M.lookup scsk c) - let c' = if (yesNo =<< M.lookup "embedcreds" c) == Just True - then flip M.union c $ M.fromList - [ (furlk, furl) - , (scsk, scs) - ] - else c + scs <- liftIO $ tahoeConfigure configdir + (fromProposedAccepted furl) + (fromProposedAccepted <$> (M.lookup scsk c)) + let c' = case parseProposedAccepted embedCredsField c yesNo False "yes or no" of + Right (Just True) -> + flip M.union c $ M.fromList + [ (furlk, furl) + , (scsk, Proposed scs) + ] + Right _ -> c + Left err -> giveup err gitConfigSpecialRemote u c' [("tahoe", configdir)] return (c', u) where - scsk = "shared-convergence-secret" - furlk = "introducer-furl" + scsk = Accepted "shared-convergence-secret" + furlk = Accepted "introducer-furl" missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 08c3d528cc..c5ef04e8cb 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -39,6 +39,7 @@ import Utility.Metered import Utility.Url (URLString, matchStatusCodeException, matchHttpExceptionContent) import Annex.UUID import Remote.WebDAV.DavLocation +import Types.ProposedAccepted remote :: RemoteType remote = RemoteType @@ -95,9 +96,9 @@ gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost , appendonly = False , availability = GloballyAvailable , remotetype = remote - , mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc rs + , mkUnavailable = gen r u (M.insert (Accepted "url") (Accepted "http://!dne!/") c) gc rs , getInfo = includeCredsInfo c (davCreds u) $ - [("url", fromMaybe "unknown" (M.lookup "url" c))] + [("url", maybe "unknown" fromProposedAccepted (M.lookup (Accepted "url") c))] , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs @@ -107,9 +108,9 @@ gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost webdavSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) webdavSetup _ mu mcreds c gc = do u <- maybe (liftIO genUUID) return mu - url <- case M.lookup "url" c of - Nothing -> giveup "Specify url=" - Just url -> return url + url <- maybe (giveup "Specify url=") + (return . fromProposedAccepted) + (M.lookup (Accepted "url") c) (c', encsetup) <- encryptionSetup c gc creds <- maybe (getCreds c' gc u) (return . Just) mcreds testDav url creds @@ -255,7 +256,8 @@ runExport Nothing _ = return False runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h)) configUrl :: Remote -> Maybe URLString -configUrl r = fixup <$> M.lookup "url" (config r) +configUrl r = fixup . fromProposedAccepted + <$> M.lookup (Accepted "url") (config r) where -- box.com DAV url changed fixup = replace "https://www.box.com/dav/" boxComUrl @@ -342,7 +344,7 @@ davCreds :: UUID -> CredPairStorage davCreds u = CredPairStorage { credPairFile = fromUUID u , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD") - , credPairRemoteField = "davcreds" + , credPairRemoteField = Accepted "davcreds" } {- Content-Type to use for files uploaded to WebDAV. -} diff --git a/Types/ProposedAccepted.hs b/Types/ProposedAccepted.hs new file mode 100644 index 0000000000..b0c3f2679b --- /dev/null +++ b/Types/ProposedAccepted.hs @@ -0,0 +1,64 @@ +{- proposed and accepted values + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.ProposedAccepted where + +import qualified Data.Map as M +import Test.QuickCheck + +-- | A value that may be proposed, or accepted. +-- +-- When parsing/validating the value, may want to error out on invalid +-- input. But if a previous version of git-annex accepted an invalid value, +-- it's too late to error out, and instead the bad value may be ignored. +data ProposedAccepted t = Proposed t | Accepted t + deriving (Show) + +fromProposedAccepted :: ProposedAccepted t -> t +fromProposedAccepted (Proposed t) = t +fromProposedAccepted (Accepted t) = t + +-- | Whether a value is proposed or accepted does not matter when checking +-- equality. +instance Eq t => Eq (ProposedAccepted t) where + a == b = fromProposedAccepted a == fromProposedAccepted b + +-- | Order by the contained value, not by whether it's proposed or +-- accepted. +instance Ord t => Ord (ProposedAccepted t) where + compare a b = compare (fromProposedAccepted a) (fromProposedAccepted b) + +instance Arbitrary t => Arbitrary (ProposedAccepted t) where + arbitrary = oneof + [ 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 0604228f86..65e74910d8 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -42,6 +42,7 @@ import Types.UrlContents import Types.NumCopies import Types.Export import Types.Import +import Types.ProposedAccepted import Config.Cost import Utility.Metered import Git.Types (RemoteName) @@ -49,9 +50,9 @@ import Utility.SafeCommand import Utility.Url import Utility.DataUnits -type RemoteConfigField = String +type RemoteConfigField = ProposedAccepted String -type RemoteConfig = M.Map RemoteConfigField String +type RemoteConfig = M.Map RemoteConfigField (ProposedAccepted String) data SetupStage = Init | Enable RemoteConfig diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs index 5f00903570..bc19ff1a27 100644 --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -11,9 +11,9 @@ module Types.StandardGroups where import Types.Remote (RemoteConfig) import Types.Group +import Types.ProposedAccepted import qualified Data.Map as M -import Data.Maybe type PreferredContentExpression = String @@ -71,7 +71,8 @@ associatedDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath associatedDirectory _ SmallArchiveGroup = Just "archive" associatedDirectory _ FullArchiveGroup = Just "archive" associatedDirectory (Just c) PublicGroup = Just $ - fromMaybe "public" $ M.lookup "preferreddir" c + maybe "public" fromProposedAccepted $ + M.lookup (Accepted "preferreddir") c associatedDirectory Nothing PublicGroup = Just "public" associatedDirectory _ _ = Nothing diff --git a/doc/todo/assure_correct_names___40__and_values__41___for_special_remotes_parameters/comment_2_afa8c10bd3b1df649c1f643430b300e9._comment b/doc/todo/assure_correct_names___40__and_values__41___for_special_remotes_parameters/comment_2_afa8c10bd3b1df649c1f643430b300e9._comment index 47f70e8bb8..d5c16d746f 100644 --- a/doc/todo/assure_correct_names___40__and_values__41___for_special_remotes_parameters/comment_2_afa8c10bd3b1df649c1f643430b300e9._comment +++ b/doc/todo/assure_correct_names___40__and_values__41___for_special_remotes_parameters/comment_2_afa8c10bd3b1df649c1f643430b300e9._comment @@ -6,18 +6,21 @@ I was thinking about implementing this today, but the shattered attack got in the way. Anyway, it seems like most of a plan: -* Make RemoteConfig contain Old or New values. enableremote and initremote - set New values; Old values are anything read from git-annex:remote.log +* Make RemoteConfig contain Accepted or Proposed values. enableremote and initremote + set Proposed values; Accepted values are anything read from git-annex:remote.log + (update: done) * When a RemoteConfig value fails to parse, it may make sense to use a - default instead when it's Old, and error out when it's New. This could + default instead when it's Accepted, and error out when it's Proposed. This could be used when parsing foo=yes/no to avoid treating foo=true the same as foo=no, which some things do currently do (eg importtree, exporttree, embedcreds). + (update: Done for most yes/no and true/false parsers, surely missed a + few though, (including autoenable).) * Add a Remote method that returns a list of all RemoteConfig fields it uses. This is the one part I'm not sure about, because that violates DRY. It would be nicer to have a parser that can also generate a list of the fields it parses. -* Before calling Remote setup, see if there is any New value in +* Before calling Remote setup, see if there is any Proposed value in RemoteConfig whose field is not in the list. If so, error out. * For external special remotes, add a LISTCONFIG message. The program reponds with a list of all the fields it may want to later GETCONFIG. diff --git a/git-annex.cabal b/git-annex.cabal index afd400b87a..d6010d92fe 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -995,6 +995,7 @@ Executable git-annex Types.MetaData Types.Mime Types.NumCopies + Types.ProposedAccepted Types.RefSpec Types.Remote Types.RemoteState