mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

be stricter about rejecting invalid configurations for remotes

Browse source 
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 2020-01-10 14:10:20 -04:00
parent ea3f206fd1
commit 71ecfbfccf
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
45 changed files with 395 additions and 224 deletions
Download patch file Download diff file Expand all files Collapse all files

11
Remote/Adb.hs
View file

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

5
Remote/Bup.hs
View file

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

5
Remote/Ddar.hs
View file

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

7
Remote/Directory.hs
View file

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

18
Remote/External.hs
View file

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

3
Remote/GCrypt.hs
View file

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

6
Remote/Git.hs
View file

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

10
Remote/GitLFS.hs
View file

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

16
Remote/Glacier.hs
View file

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

3
Remote/Helper/AWS.hs
View file

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

9
Remote/Helper/Chunked.hs
View file

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

35
Remote/Helper/Encryptable.hs
View file

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

21
Remote/Helper/ExportImport.hs
View file

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

5
Remote/Hook.hs
View file

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

10
Remote/Rsync.hs
View file

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

77
Remote/S3.hs
View file

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

26
Remote/Tahoe.hs
View file

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

16
Remote/WebDAV.hs
View file

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