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

wip separate RemoteConfig parsing

Browse source 
Remote now contains a ParsedRemoteConfig. The parsing happens when the
Remote is constructed, rather than when individual configs are used.

This is more efficient, and it lets initremote/enableremote
reject configs that have unknown fields or unparsable values.

It also allows for improved type safety, as shown in
Remote.Helper.Encryptable where things that used to match on string
configs now match on data types.

This is a work in progress, it does not build yet.

The main risk in this conversion is forgetting to add a field to
RemoteConfigParser. That will prevent using that field with
initremote/enableremote, and will prevent remotes that already are set
up from seeing that configuration. So will need to check carefully that
every field that getRemoteConfigValue is called on has been added to
RemoteConfigParser.

(One such case I need to remember is that credPairRemoteField needs to be
included in the RemoteConfigParser.)
This commit is contained in:
Joey Hess 2020-01-13 12:35:39 -04:00
parent 4a135934ff
commit 71f78fe45d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
10 changed files with 266 additions and 101 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Annex/SpecialRemote/Config.hs
View file

@ -60,6 +60,9 @@ cipherkeysField = Accepted "cipherkeys"
pubkeysField :: RemoteConfigField pubkeysField :: RemoteConfigField
pubkeysField = Accepted "pubkeys" pubkeysField = Accepted "pubkeys"
chunkField :: RemoteConfigField
chunkField = Accepted "chunk"
chunksizeField :: RemoteConfigField chunksizeField :: RemoteConfigField
chunksizeField = Accepted "chunksize" chunksizeField = Accepted "chunksize"

44
Config/RemoteConfig.hs Normal file
View file

@ -0,0 +1,44 @@
{- git-annex remote config parsing
-
- Copyright 2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Config.RemoteConfig where
import qualified Data.Map as M
import Data.Typeable
import Types.RemoteConfig
import Types.ProposedAccepted
import Config
parseRemoteConfig :: RemoteConfig -> [RemoteConfigParser] -> Either String ParsedRemoteConfig
parseRemoteConfig c = go [] (M.filterWithKey notaccepted c)
where
go l c' []
| M.null c' = Right (M.fromList l)
| otherwise = Left $ "Unexpected fields: " ++
unwords (map fromProposedAccepted (M.keys c'))
go l c' ((f, p):rest) = do
v <- p (M.lookup f c) c
go ((f,v):l) (M.delete f c') rest
notaccepted (Proposed _) _ = True
notaccepted (Accepted _) _ = False
yesNoParser :: RemoteConfigField -> Bool -> RemoteConfigParser
yesNoParser f fallback = (f, p)
where
p v _c = case v of
Nothing -> Right (RemoteConfigValue fallback)
Just v' -> case yesNo (fromProposedAccepted v') of
Just b -> Right (RemoteConfigValue b)
Nothing -> case v' of
Accepted _ -> Right (RemoteConfigValue fallback)
Proposed _ -> Left $
"bad " ++ fromProposedAccepted f ++
" value (expected yes or no)"
optStringParser :: RemoteConfigField -> RemoteConfigParser
optStringParser f = (f, \v _c -> Right (RemoteConfigValue v))

32
Creds.hs
View file

@ -23,12 +23,14 @@ module Creds (
import Annex.Common import Annex.Common
import qualified Annex import qualified Annex
import Types.Creds import Types.Creds
import Types.RemoteConfig
import Config.RemoteConfig
import Annex.Perms import Annex.Perms
import Utility.FileMode import Utility.FileMode
import Crypto import Crypto
import Types.Remote (RemoteConfig, RemoteConfigField) import Types.Remote (RemoteConfig, RemoteConfigField)
import Types.ProposedAccepted import Types.ProposedAccepted
import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher) import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher, encryptionConfigParser)
import Utility.Env (getEnv) import Utility.Env (getEnv)
import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.Char8 as L
@ -56,30 +58,34 @@ data CredPairStorage = CredPairStorage
setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
setRemoteCredPair encsetup c gc storage mcreds = case mcreds of setRemoteCredPair encsetup c gc storage mcreds = case mcreds of
Nothing -> maybe (return c) (setRemoteCredPair encsetup c gc storage . Just) Nothing -> maybe (return c) (setRemoteCredPair encsetup c gc storage . Just)
=<< getRemoteCredPair c gc storage =<< getRemoteCredPair pc gc storage
Just creds Just creds
| embedCreds c -> | embedCreds pc -> do
let key = credPairRemoteField storage let key = credPairRemoteField storage
in storeconfig creds key =<< flip remoteCipher gc =<< localcache creds localcache creds
| otherwise -> localcache creds storeconfig creds key =<< remoteCipher pc gc
where | otherwise -> do
localcache creds = do localcache creds
writeCacheCredPair creds storage
return c return c
where
localcache creds = writeCacheCredPair creds storage
storeconfig creds key (Just cipher) = do storeconfig creds key (Just cipher) = do
cmd <- gpgCmd <$> Annex.getGitConfig cmd <- gpgCmd <$> Annex.getGitConfig
s <- liftIO $ encrypt cmd (c, gc) cipher s <- liftIO $ encrypt cmd (pc, gc) cipher
(feedBytes $ L.pack $ encodeCredPair creds) (feedBytes $ L.pack $ encodeCredPair creds)
(readBytes $ return . L.unpack) (readBytes $ return . L.unpack)
return $ M.insert key (Accepted (toB64 s)) c return $ M.insert key (Accepted (toB64 s)) c
storeconfig creds key Nothing = storeconfig creds key Nothing =
return $ M.insert key (Accepted (toB64 $ encodeCredPair creds)) c return $ M.insert key (Accepted (toB64 $ encodeCredPair creds)) c
pc = either (const mempty) id
(parseRemoteConfig c encryptionConfigParser)
{- Gets a remote's credpair, from the environment if set, otherwise {- Gets a remote's credpair, from the environment if set, otherwise
- from the cache in gitAnnexCredsDir, or failing that, from the - from the cache in gitAnnexCredsDir, or failing that, from the
- value in RemoteConfig. -} - value in RemoteConfig. -}
getRemoteCredPair :: RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair) getRemoteCredPair :: ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
where where
fromenv = liftIO $ getEnvCredPair storage fromenv = liftIO $ getEnvCredPair storage
@ -87,7 +93,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
fromconfig = do fromconfig = do
let key = credPairRemoteField storage let key = credPairRemoteField storage
mcipher <- remoteCipher' c gc mcipher <- remoteCipher' c gc
case (fromProposedAccepted <$> M.lookup key c, mcipher) of case (fromProposedAccepted <$> getRemoteConfigValue key c, mcipher) of
(Nothing, _) -> return Nothing (Nothing, _) -> return Nothing
(Just enccreds, Just (cipher, storablecipher)) -> (Just enccreds, Just (cipher, storablecipher)) ->
fromenccreds enccreds cipher storablecipher fromenccreds enccreds cipher storablecipher
@ -115,7 +121,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
return $ Just credpair return $ Just credpair
_ -> error "bad creds" _ -> error "bad creds"
getRemoteCredPairFor :: String -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair) getRemoteCredPairFor :: String -> ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage
where where
go Nothing = do go Nothing = do
@ -184,7 +190,7 @@ removeCreds file = do
let f = d </> file let f = d </> file
liftIO $ nukeFile f liftIO $ nukeFile f
includeCredsInfo :: RemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)]
includeCredsInfo c storage info = do includeCredsInfo c storage info = do
v <- liftIO $ getEnvCredPair storage v <- liftIO $ getEnvCredPair storage
case v of case v of

26
Crypto.hs
View file

@ -3,7 +3,7 @@
- Currently using gpg; could later be modified to support different - Currently using gpg; could later be modified to support different
- crypto backends if neccessary. - crypto backends if neccessary.
- -
- Copyright 2011-2016 Joey Hess <id@joeyh.name> - Copyright 2011-2020 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -13,6 +13,7 @@
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
module Crypto ( module Crypto (
EncryptionMethod(..),
Cipher, Cipher,
KeyIds(..), KeyIds(..),
EncKey, EncKey,
@ -37,17 +38,24 @@ module Crypto (
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.ByteString.UTF8 (fromString) import Data.ByteString.UTF8 (fromString)
import qualified Data.Map as M
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Typeable
import Annex.Common import Annex.Common
import qualified Utility.Gpg as Gpg import qualified Utility.Gpg as Gpg
import Types.Crypto import Types.Crypto
import Types.Remote import Types.Remote
import Types.Key import Types.Key
import Types.ProposedAccepted
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
data EncryptionMethod
= NoneEncryption
| SharedEncryption
| PubKeyEncryption
| SharedPubKeyEncryption
| HybridEncryption
deriving (Typeable, Eq)
{- The beginning of a Cipher is used for MAC'ing; the remainder is used {- The beginning of a Cipher is used for MAC'ing; the remainder is used
- as the GPG symmetric encryption passphrase when using the hybrid - as the GPG symmetric encryption passphrase when using the hybrid
- scheme. Note that the cipher itself is base-64 encoded, hence the - scheme. Note that the cipher itself is base-64 encoded, hence the
@ -233,14 +241,18 @@ class LensGpgEncParams a where
{- Extract the GnuPG options from a pair of a Remote Config and a Remote {- Extract the GnuPG options from a pair of a Remote Config and a Remote
- Git Config. -} - Git Config. -}
instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where instance LensGpgEncParams (ParsedRemoteConfig, RemoteGitConfig) where
getGpgEncParamsBase (_c,gc) = map Param (remoteAnnexGnupgOptions gc) getGpgEncParamsBase (_c,gc) = map Param (remoteAnnexGnupgOptions gc)
getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++ getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++
{- When the remote is configured to use public-key encryption, {- When the remote is configured to use public-key encryption,
- look up the recipient keys and add them to the option list. -} - look up the recipient keys and add them to the option list. -}
case fromProposedAccepted <$> M.lookup encryptionField c of case getRemoteConfigValue encryptionField c of
Just "pubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',' . fromProposedAccepted) $ M.lookup cipherkeysField c Just PubKeyEncryption ->
Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (splitc ',' . fromProposedAccepted) $ M.lookup pubkeysField c Gpg.pkEncTo $ maybe [] (splitc ',') $
getRemoteConfigValue cipherkeysField c
Just SharedPubKeyEncryption ->
Gpg.pkEncTo $ maybe [] (splitc ',') $
getRemoteConfigValue pubkeysField c
_ -> [] _ -> []
getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc) getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc)

25
Remote/Helper/Chunked.hs
View file

@ -1,6 +1,6 @@
{- git-annex chunked remotes {- git-annex chunked remotes
- -
- Copyright 2014 Joey Hess <id@joeyh.name> - Copyright 2014-2020 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -10,6 +10,7 @@ module Remote.Helper.Chunked (
ChunkConfig(..), ChunkConfig(..),
noChunks, noChunks,
describeChunkConfig, describeChunkConfig,
chunkConfigParser,
getChunkConfig, getChunkConfig,
storeChunks, storeChunks,
removeChunks, removeChunks,
@ -27,9 +28,9 @@ import Utility.Metered
import Crypto (EncKey) import Crypto (EncKey)
import Backend (isStableKey) import Backend (isStableKey)
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import Config.RemoteConfig
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
data ChunkConfig data ChunkConfig
= NoChunks = NoChunks
@ -49,18 +50,24 @@ noChunks :: ChunkConfig -> Bool
noChunks NoChunks = True noChunks NoChunks = True
noChunks _ = False noChunks _ = False
getChunkConfig :: RemoteConfig -> ChunkConfig chunkConfigParser :: [RemoteConfigParser]
getChunkConfig m = chunkConfigParser =
case M.lookup chunksizeField m of [ optStringParser chunksizeField
Nothing -> case M.lookup (Accepted "chunk") m of , optStringParser chunkField
]
getChunkConfig :: ParsedRemoteConfig -> ChunkConfig
getChunkConfig c =
case getRemoteConfigValue chunksizeField c of
Nothing -> case getRemoteConfigValue chunkField c of
Nothing -> NoChunks Nothing -> NoChunks
Just v -> readsz UnpaddedChunks (fromProposedAccepted v) (Accepted "chunk") Just v -> readsz UnpaddedChunks (fromProposedAccepted v) chunkField
Just v -> readsz LegacyChunks (fromProposedAccepted v) chunksizeField Just v -> readsz LegacyChunks (fromProposedAccepted v) chunksizeField
where where
readsz c v f = case readSize dataUnits v of readsz mk v f = case readSize dataUnits v of
Just size Just size
| size == 0 -> NoChunks | size == 0 -> NoChunks
| size > 0 -> c (fromInteger size) | size > 0 -> mk (fromInteger size)
_ -> giveup $ "bad configuration " ++ fromProposedAccepted f ++ "=" ++ v _ -> giveup $ "bad configuration " ++ fromProposedAccepted f ++ "=" ++ v
-- An infinite stream of chunk keys, starting from chunk 1. -- An infinite stream of chunk keys, starting from chunk 1.

155
Remote/Helper/Encryptable.hs
View file

@ -1,15 +1,18 @@
{- common functions for encryptable remotes {- common functions for encryptable remotes
- -
- Copyright 2011 Joey Hess <id@joeyh.name> - Copyright 2011-2020 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
module Remote.Helper.Encryptable ( module Remote.Helper.Encryptable (
EncryptionIsSetup, EncryptionIsSetup,
encryptionSetup, encryptionSetup,
noEncryptionUsed, noEncryptionUsed,
encryptionAlreadySetup, encryptionAlreadySetup,
encryptionConfigParser,
remoteCipher, remoteCipher,
remoteCipher', remoteCipher',
embedCreds, embedCreds,
@ -25,7 +28,7 @@ import qualified Data.ByteString as B
import Annex.Common import Annex.Common
import Types.Remote import Types.Remote
import Config import Config.RemoteConfig
import Crypto import Crypto
import Types.Crypto import Types.Crypto
import Types.ProposedAccepted import Types.ProposedAccepted
@ -47,68 +50,117 @@ noEncryptionUsed = NoEncryption
encryptionAlreadySetup :: EncryptionIsSetup encryptionAlreadySetup :: EncryptionIsSetup
encryptionAlreadySetup = EncryptionIsSetup encryptionAlreadySetup = EncryptionIsSetup
encryptionConfigParser :: [RemoteConfigParser]
encryptionConfigParser =
[ (encryptionField, \v c -> RemoteConfigValue <$> parseEncryptionMethod (fmap fromProposedAccepted v) c)
, optStringParser cipherField
, optStringParser cipherkeysField
, optStringParser pubkeysField
, yesNoParser embedCredsField False
, (macField, \v _c -> RemoteConfigValue <$> parseMac v)
, optStringParser (Accepted "keyid")
, optStringParser (Accepted "keyid+")
, optStringParser (Accepted "keyid-")
, (Accepted "highRandomQuality", \v _c -> RemoteConfigValue <$> parseHighRandomQuality (fmap fromProposedAccepted v))
]
parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod
parseEncryptionMethod (Just "none") _ = Right NoneEncryption
parseEncryptionMethod (Just "shared") _ = Right SharedEncryption
parseEncryptionMethod (Just "hybrid") _ = Right HybridEncryption
parseEncryptionMethod (Just "pubkey") _ = Right PubKeyEncryption
parseEncryptionMethod (Just "sharedpubkey") _ = Right SharedPubKeyEncryption
-- Hybrid encryption is the default when a keyid is specified without
-- an encryption field, or when there's a cipher already but no encryption
-- field.
parseEncryptionMethod Nothing c
| M.member (Accepted "keyid") c || M.member cipherField c = Right HybridEncryption
parseEncryptionMethod _ _ =
Left $ "Specify " ++ intercalate " or "
(map ((fromProposedAccepted encryptionField ++ "=") ++)
["none","shared","hybrid","pubkey", "sharedpubkey"])
++ "."
parseHighRandomQuality :: Maybe String -> Either String Bool
parseHighRandomQuality Nothing = Right True
parseHighRandomQuality (Just "false") = Right False
parseHighRandomQuality (Just "true") = Right True
parseHighRandomQuality _ = Left "expected highRandomQuality=true/false"
parseMac :: Maybe (ProposedAccepted String) -> Either String Mac
parseMac Nothing = Right defaultMac
parseMac (Just (Accepted s)) = Right $ fromMaybe defaultMac (readMac s)
parseMac (Just (Proposed s)) = case readMac s of
Just mac -> Right mac
Nothing -> Left "bad mac value"
{- Encryption setup for a remote. The user must specify whether to use {- Encryption setup for a remote. The user must specify whether to use
- an encryption key, or not encrypt. An encrypted cipher is created, or is - an encryption key, or not encrypt. An encrypted cipher is created, or is
- updated to be accessible to an additional encryption key. Or the user - updated to be accessible to an additional encryption key. Or the user
- could opt to use a shared cipher, which is stored unencrypted. -} - could opt to use a shared cipher, which is stored unencrypted. -}
encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup) encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup)
encryptionSetup c gc = do encryptionSetup c gc = do
pc <- either giveup return $ parseRemoteConfig c encryptionConfigParser
cmd <- gpgCmd <$> Annex.getGitConfig cmd <- gpgCmd <$> Annex.getGitConfig
maybe (genCipher cmd) (updateCipher cmd) (extractCipher c) maybe (genCipher pc cmd) (updateCipher pc cmd) (extractCipher pc)
where where
-- The type of encryption -- The type of encryption
encryption = fromProposedAccepted <$> M.lookup encryptionField c encryption = parseEncryptionMethod (fromProposedAccepted <$> M.lookup encryptionField c) c
-- Generate a new cipher, depending on the chosen encryption scheme -- Generate a new cipher, depending on the chosen encryption scheme
genCipher cmd = case encryption of genCipher pc cmd = case encryption of
_ | hasEncryptionConfig c -> cannotchange Right NoneEncryption -> return (c, NoEncryption)
Just "none" -> return (c, NoEncryption) Right SharedEncryption -> encsetup $ genSharedCipher cmd
Just "shared" -> encsetup $ genSharedCipher cmd Right HybridEncryption -> encsetup $ genEncryptedCipher cmd (pc, gc) key Hybrid
-- hybrid encryption is the default when a keyid is Right PubKeyEncryption -> encsetup $ genEncryptedCipher cmd (pc, gc) key PubKey
-- specified but no encryption Right SharedPubKeyEncryption -> encsetup $ genSharedPubKeyCipher cmd key
_ | maybe (M.member (Accepted "keyid") c) (== "hybrid") encryption -> Left err -> giveup err
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 ((fromProposedAccepted encryptionField ++ "=") ++)
["none","shared","hybrid","pubkey", "sharedpubkey"])
++ "."
key = maybe (giveup "Specify keyid=...") fromProposedAccepted $ key = maybe (giveup "Specify keyid=...") fromProposedAccepted $
M.lookup (Accepted "keyid") c M.lookup (Accepted "keyid") c
newkeys = maybe [] (\k -> [(True,fromProposedAccepted k)]) (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) maybe [] (\k -> [(False,fromProposedAccepted k)]) (M.lookup (Accepted "keyid-") c)
cannotchange = giveup "Cannot set encryption type of existing remotes." cannotchange = giveup "Cannot set encryption type of existing remotes."
-- Update an existing cipher if possible. -- Update an existing cipher if possible.
updateCipher cmd v = case v of updateCipher pc cmd v = case v of
SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup) SharedCipher _ | encryption == Right SharedEncryption ->
EncryptedCipher _ variant _ return (c', EncryptionIsSetup)
| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption -> do EncryptedCipher _ variant _ | sameasencryption variant ->
use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v use "encryption update" $ updateCipherKeyIds cmd (pc, gc) newkeys v
SharedPubKeyCipher _ _ -> SharedPubKeyCipher _ _ ->
use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v use "encryption update" $ updateCipherKeyIds cmd (pc, gc) newkeys v
_ -> cannotchange _ -> cannotchange
sameasencryption variant = case encryption of
Right HybridEncryption -> variant == Hybrid
Right PubKeyEncryption -> variant == PubKey
Right _ -> False
Left _ -> True
encsetup a = use "encryption setup" . a =<< highRandomQuality encsetup a = use "encryption setup" . a =<< highRandomQuality
use m a = do use m a = do
showNote m showNote m
cipher <- liftIO a cipher <- liftIO a
showNote (describeCipher cipher) showNote (describeCipher cipher)
return (storeCipher cipher c', EncryptionIsSetup) return (storeCipher cipher c', EncryptionIsSetup)
highRandomQuality = highRandomQuality = ifM (Annex.getState Annex.fast)
(&&) (maybe True (\v -> fromProposedAccepted v /= "false") $ M.lookup (Accepted "highRandomQuality") c) ( return False
<$> fmap not (Annex.getState Annex.fast) , case parseHighRandomQuality (fromProposedAccepted <$> M.lookup (Accepted "highRandomQuality") c) of
Left err -> giveup err
Right v -> return v
)
c' = foldr M.delete c c' = foldr M.delete c
-- git-annex used to remove 'encryption' as well, since -- Remove configs that are only used in here to generate
-- the encryption keys, and should not be stored in
-- remote.log.
-- Older versions used to remove 'encryption' as well, since
-- it was redundant; we now need to keep it for -- it was redundant; we now need to keep it for
-- public-key encryption, hence we leave it on newer -- public-key encryption, hence we leave it on newer
-- remotes (while being backward-compatible). -- remotes (while being backward-compatible).
(map Accepted ["keyid", "keyid+", "keyid-", "highRandomQuality"]) (map Accepted ["keyid", "keyid+", "keyid-", "highRandomQuality"])
remoteCipher :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher) remoteCipher :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher)
remoteCipher c gc = fmap fst <$> remoteCipher' c gc remoteCipher c gc = fmap fst <$> remoteCipher' c gc
{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
- state. -} - state. -}
remoteCipher' :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher)) remoteCipher' :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher))
remoteCipher' c gc = go $ extractCipher c remoteCipher' c gc = go $ extractCipher c
where where
go Nothing = return Nothing go Nothing = return Nothing
@ -130,18 +182,19 @@ remoteCipher' c gc = go $ extractCipher c
- When gpg encryption is used and the creds are encrypted using it. - When gpg encryption is used and the creds are encrypted using it.
- Not when a shared cipher is used. - Not when a shared cipher is used.
-} -}
embedCreds :: RemoteConfig -> Bool embedCreds :: ParsedRemoteConfig -> Bool
embedCreds c = case yesNo . fromProposedAccepted =<< M.lookup embedCredsField c of embedCreds c = case getRemoteConfigValue embedCredsField c of
Just v -> v Just v -> v
Nothing -> isJust (M.lookup cipherkeysField c) && isJust (M.lookup cipherField c) Nothing -> case (getRemoteConfigValue cipherkeysField c, getRemoteConfigValue cipherField c) of
(Just (_ :: ProposedAccepted String), Just (_ :: ProposedAccepted String)) -> True
_ -> False
{- Gets encryption Cipher, and key encryptor. -} {- Gets encryption Cipher, and key encryptor. -}
cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey)) cipherKey :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))
cipherKey c gc = fmap make <$> remoteCipher c gc cipherKey c gc = fmap make <$> remoteCipher c gc
where where
make ciphertext = (ciphertext, encryptKey mac ciphertext) make ciphertext = (ciphertext, encryptKey mac ciphertext)
mac = fromMaybe defaultMac $ mac = fromMaybe defaultMac $ getRemoteConfigValue macField c
M.lookup macField c >>= readMac . fromProposedAccepted
{- Stores an StorableCipher in a remote's configuration. -} {- Stores an StorableCipher in a remote's configuration. -}
storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig
@ -154,34 +207,26 @@ storeCipher cip = case cip of
storekeys (KeyIds l) n = M.insert n (Accepted (intercalate "," l)) storekeys (KeyIds l) n = M.insert n (Accepted (intercalate "," l))
{- Extracts an StorableCipher from a remote's configuration. -} {- Extracts an StorableCipher from a remote's configuration. -}
extractCipher :: RemoteConfig -> Maybe StorableCipher extractCipher :: ParsedRemoteConfig -> Maybe StorableCipher
extractCipher c = case (fromProposedAccepted <$> M.lookup cipherField c, extractCipher c = case (getRemoteConfigValue cipherField c,
fromProposedAccepted <$> (M.lookup cipherkeysField c <|> M.lookup pubkeysField c), (getRemoteConfigValue cipherkeysField c <|> getRemoteConfigValue pubkeysField c),
fromProposedAccepted <$> M.lookup encryptionField c) of getRemoteConfigValue encryptionField c) of
(Just t, Just ks, encryption) | maybe True (== "hybrid") encryption -> (Just t, Just ks, Just HybridEncryption) ->
Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks) Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks)
(Just t, Just ks, Just "pubkey") -> (Just t, Just ks, Just PubKeyEncryption) ->
Just $ EncryptedCipher (fromB64bs t) PubKey (readkeys ks) Just $ EncryptedCipher (fromB64bs t) PubKey (readkeys ks)
(Just t, Just ks, Just "sharedpubkey") -> (Just t, Just ks, Just SharedPubKeyEncryption) ->
Just $ SharedPubKeyCipher (fromB64bs t) (readkeys ks) Just $ SharedPubKeyCipher (fromB64bs t) (readkeys ks)
(Just t, Nothing, encryption) | maybe True (== "shared") encryption -> (Just t, Nothing, Just SharedEncryption) ->
Just $ SharedCipher (fromB64bs t) Just $ SharedCipher (fromB64bs t)
_ -> Nothing _ -> Nothing
where where
readkeys = KeyIds . splitc ',' readkeys = KeyIds . splitc ','
isEncrypted :: RemoteConfig -> Bool isEncrypted :: ParsedRemoteConfig -> Bool
isEncrypted c = case fromProposedAccepted <$> M.lookup encryptionField c of isEncrypted = isJust . extractCipher
Just "none" -> False
Just _ -> True
Nothing -> hasEncryptionConfig c
hasEncryptionConfig :: RemoteConfig -> Bool describeEncryption :: ParsedRemoteConfig -> String
hasEncryptionConfig c = M.member cipherField c
|| M.member cipherkeysField c
|| M.member pubkeysField c
describeEncryption :: RemoteConfig -> String
describeEncryption c = case extractCipher c of describeEncryption c = case extractCipher c of
Nothing -> "none" Nothing -> "none"
Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")" Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")"

12
Remote/Helper/Special.hs
View file

@ -1,6 +1,6 @@
{- helpers for special remotes {- helpers for special remotes
- -
- Copyright 2011-2019 Joey Hess <id@joeyh.name> - Copyright 2011-2020 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -28,6 +28,7 @@ module Remote.Helper.Special (
retreiveKeyFileDummy, retreiveKeyFileDummy,
removeKeyDummy, removeKeyDummy,
checkPresentDummy, checkPresentDummy,
specialRemoteConfigParser,
SpecialRemoteCfg(..), SpecialRemoteCfg(..),
specialRemoteCfg, specialRemoteCfg,
specialRemote, specialRemote,
@ -149,7 +150,7 @@ checkPresentDummy :: Key -> Annex Bool
checkPresentDummy _ = error "missing checkPresent implementation" checkPresentDummy _ = error "missing checkPresent implementation"
type RemoteModifier type RemoteModifier
= RemoteConfig = ParsedRemoteConfig
-> Preparer Storer -> Preparer Storer
-> Preparer Retriever -> Preparer Retriever
-> Preparer Remover -> Preparer Remover
@ -157,12 +158,15 @@ type RemoteModifier
-> Remote -> Remote
-> Remote -> Remote
specialRemoteConfigParser :: [RemoteConfigParser]
specialRemoteConfigParser = chunkConfigParser ++ encryptionConfigParser
data SpecialRemoteCfg = SpecialRemoteCfg data SpecialRemoteCfg = SpecialRemoteCfg
{ chunkConfig :: ChunkConfig { chunkConfig :: ChunkConfig
, displayProgress :: Bool , displayProgress :: Bool
} }
specialRemoteCfg :: RemoteConfig -> SpecialRemoteCfg specialRemoteCfg :: ParsedRemoteConfig -> SpecialRemoteCfg
specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True
-- Modifies a base Remote to support both chunking and encryption, -- Modifies a base Remote to support both chunking and encryption,
@ -212,7 +216,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
} }
} }
cip = cipherKey c (gitconfig baser) cip = cipherKey c (gitconfig baser)
isencrypted = isJust (extractCipher c) isencrypted = isEncrypted c
safely a = catchNonAsync a (\e -> warning (show e) >> return False) safely a = catchNonAsync a (\e -> warning (show e) >> return False)

20
Types/Remote.hs
View file

@ -2,7 +2,7 @@
- -
- Most things should not need this, using Types instead - Most things should not need this, using Types instead
- -
- Copyright 2011-2019 Joey Hess <id@joeyh.name> - Copyright 2011-2020 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -10,8 +10,7 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
module Types.Remote module Types.Remote
( RemoteConfigField ( module Types.RemoteConfig
, RemoteConfig
, RemoteTypeA(..) , RemoteTypeA(..)
, RemoteA(..) , RemoteA(..)
, RemoteStateHandle , RemoteStateHandle
@ -28,7 +27,6 @@ module Types.Remote
) )
where where
import qualified Data.Map as M
import Data.Ord import Data.Ord
import qualified Git import qualified Git
@ -42,7 +40,7 @@ import Types.UrlContents
import Types.NumCopies import Types.NumCopies
import Types.Export import Types.Export
import Types.Import import Types.Import
import Types.ProposedAccepted import Types.RemoteConfig
import Config.Cost import Config.Cost
import Utility.Metered import Utility.Metered
import Git.Types (RemoteName) import Git.Types (RemoteName)
@ -50,10 +48,6 @@ import Utility.SafeCommand
import Utility.Url import Utility.Url
import Utility.DataUnits import Utility.DataUnits
type RemoteConfigField = ProposedAccepted String
type RemoteConfig = M.Map RemoteConfigField (ProposedAccepted String)
data SetupStage = Init | Enable RemoteConfig data SetupStage = Init | Enable RemoteConfig
{- There are different types of remotes. -} {- There are different types of remotes. -}
@ -63,14 +57,16 @@ data RemoteTypeA a = RemoteType
-- enumerates remotes of this type -- enumerates remotes of this type
-- The Bool is True if automatic initialization of remotes is desired -- The Bool is True if automatic initialization of remotes is desired
, enumerate :: Bool -> a [Git.Repo] , enumerate :: Bool -> a [Git.Repo]
-- parse configs of remotes of this type
, configParser :: [RemoteConfigParser]
-- generates a remote of this type -- generates a remote of this type
, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a)) , generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
-- initializes or enables a remote -- initializes or enables a remote
, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) , setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
-- check if a remote of this type is able to support export -- check if a remote of this type is able to support export
, exportSupported :: RemoteConfig -> RemoteGitConfig -> a Bool , exportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool
-- check if a remote of this type is able to support import -- check if a remote of this type is able to support import
, importSupported :: RemoteConfig -> RemoteGitConfig -> a Bool , importSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool
} }
instance Eq (RemoteTypeA a) where instance Eq (RemoteTypeA a) where
@ -125,7 +121,7 @@ data RemoteA a = Remote
-- Runs an action to repair the remote's git repository. -- Runs an action to repair the remote's git repository.
, repairRepo :: Maybe (a Bool -> a (IO Bool)) , repairRepo :: Maybe (a Bool -> a (IO Bool))
-- a Remote has a persistent configuration store -- a Remote has a persistent configuration store
, config :: RemoteConfig , config :: ParsedRemoteConfig
-- Get the git repo for the Remote. -- Get the git repo for the Remote.
, getRepo :: a Git.Repo , getRepo :: a Git.Repo
-- a Remote's configuration from git -- a Remote's configuration from git

46
Types/RemoteConfig.hs Normal file
View file

@ -0,0 +1,46 @@
{- git-annex remote config types
-
- Copyright 2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE GADTs #-}
module Types.RemoteConfig where
import qualified Data.Map as M
import Data.Typeable
import Types.ProposedAccepted
type RemoteConfigField = ProposedAccepted String
{- What the user provides to configure the remote, and what is stored for
- later; a bunch of fields and values. -}
type RemoteConfig = M.Map RemoteConfigField (ProposedAccepted String)
{- Before being used a RemoteConfig has to be parsed. -}
type ParsedRemoteConfig = M.Map RemoteConfigField RemoteConfigValue
{- Remotes can have configuration values of many types, so use Typeable
- to let them all be stored in here. -}
data RemoteConfigValue where
RemoteConfigValue :: Typeable v => v -> RemoteConfigValue
{- Extracts the value, if the field was parsed to the requested type. -}
getRemoteConfigValue :: Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v
getRemoteConfigValue f m = case M.lookup f m of
Just (RemoteConfigValue v) -> cast v
Nothing -> Nothing
{- Parse a field's value provided by the user into a RemoteConfigValue.
-
- The RemoteConfig is provided to the parser function for cases
- where multiple fields need to be looked at. However, it's important
- that, when a parser looks at an additional field in that way, the
- parser list contains a dedicated parser for that field as well.
- Presence of fields that are not included in this list will cause
- a parse failure.
-}
type RemoteConfigParser = (RemoteConfigField, Maybe (ProposedAccepted String) -> RemoteConfig -> Either String RemoteConfigValue)

2
git-annex.cabal
View file

@ -811,6 +811,7 @@ Executable git-annex
Config.Files Config.Files
Config.DynamicConfig Config.DynamicConfig
Config.GitConfig Config.GitConfig
Config.RemoteConfig
Config.Smudge Config.Smudge
Creds Creds
Crypto Crypto
@ -998,6 +999,7 @@ Executable git-annex
Types.ProposedAccepted Types.ProposedAccepted
Types.RefSpec Types.RefSpec
Types.Remote Types.Remote
Types.RemoteConfig
Types.RemoteState Types.RemoteState
Types.RepoVersion Types.RepoVersion
Types.ScheduledActivity Types.ScheduledActivity