be stricter about rejecting invalid configurations for remotes
This is a first step toward that goal, using the ProposedAccepted type in RemoteConfig lets initremote/enableremote reject bad parameters that were passed in a remote's configuration, while avoiding enableremote rejecting bad parameters that have already been stored in remote.log This does not eliminate every place where a remote config is parsed and a default value is used if the parse false. But, I did fix several things that expected foo=yes/no and so confusingly accepted foo=true but treated it like foo=no. There are still some fields that are parsed with yesNo but not not checked when initializing a remote, and there are other fields that are parsed in other ways and not checked when initializing a remote. This also lays groundwork for rejecting unknown/typoed config keys.
This commit is contained in:
Joey Hess
parent
ea3f206fd1
commit
71ecfbfccf
45 changed files with 395 additions and 224 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,10 +132,9 @@ postAddIAR = iaConfigurator $ do
|
|||
case result of
|
||||
FormSuccess input -> liftH $ do
|
||||
let name = escapeBucket $ T.unpack $ itemName input
|
||||
AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $
|
||||
M.fromList $ catMaybes
|
||||
[ Just $ configureEncryption NoEncryption
|
||||
, Just ("type", "S3")
|
||||
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)
|
||||
|
|
@ -146,6 +146,8 @@ postAddIAR = iaConfigurator $ do
|
|||
, Just ("x-archive-interactive-priority", "1")
|
||||
, Just ("preferreddir", name)
|
||||
]
|
||||
AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) 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
|
||||
|
|
|
|||
|
|
@ -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 -> (,)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <id@joeyh.name> Wed, 01 Jan 2020 12:51:40 -0400
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
|||
15
Config.hs
15
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
|
||||
|
|
|
|||
7
Creds.hs
7
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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="
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
75
Remote/S3.hs
75
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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, scs)
|
||||
, (scsk, Proposed scs)
|
||||
]
|
||||
else c
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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. -}
|
||||
|
|
|
|||
64
Types/ProposedAccepted.hs
Normal file
64
Types/ProposedAccepted.hs
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
{- proposed and accepted values
|
||||
-
|
||||
- Copyright 2020 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- 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)
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -995,6 +995,7 @@ Executable git-annex
|
|||
Types.MetaData
|
||||
Types.Mime
|
||||
Types.NumCopies
|
||||
Types.ProposedAccepted
|
||||
Types.RefSpec
|
||||
Types.Remote
|
||||
Types.RemoteState
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue