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

separate RemoteConfig parsing basically working

Browse source 
Many special remotes are not updated yet and are commented out.
This commit is contained in:
Joey Hess 2020-01-14 12:35:08 -04:00
parent 71f78fe45d
commit 963239da5c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
26 changed files with 282 additions and 212 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Annex/Drop.hs
View file

@ -16,7 +16,7 @@ import qualified Remote
import qualified Command.Drop import qualified Command.Drop
import Command import Command
import Annex.Wanted import Annex.Wanted
import Config import Annex.SpecialRemote.Config
import qualified Database.Keys import qualified Database.Keys
import Git.FilePath import Git.FilePath

2
Annex/Import.hs
View file

@ -8,7 +8,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Annex.Import ( module Annex.Import (
importTree,
ImportTreeConfig(..), ImportTreeConfig(..),
ImportCommitConfig(..), ImportCommitConfig(..),
buildImportCommit, buildImportCommit,
@ -37,7 +36,6 @@ import Annex.Export
import Annex.RemoteTrackingBranch import Annex.RemoteTrackingBranch
import Command import Command
import Backend import Backend
import Config
import Types.Key import Types.Key
import Types.KeySource import Types.KeySource
import Messages.Progress import Messages.Progress

89
Annex/SpecialRemote/Config.hs
View file

@ -1,19 +1,27 @@
{- git-annex special remote configuration {- git-annex special remote configuration
- -
- Copyright 2019 Joey Hess <id@joeyh.name> - Copyright 2019-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 TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Annex.SpecialRemote.Config where module Annex.SpecialRemote.Config where
import Common import Common
import Types.Remote (RemoteConfigField, RemoteConfig) import Types.Remote (RemoteConfigField, RemoteConfig)
import Types.UUID import Types.UUID
import Types.ProposedAccepted import Types.ProposedAccepted
import Types.RemoteConfig
import Config
import qualified Git.Config
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
import Data.Typeable
import GHC.Stack
newtype Sameas t = Sameas t newtype Sameas t = Sameas t
deriving (Show) deriving (Show)
@ -34,6 +42,9 @@ lookupName :: RemoteConfig -> Maybe String
lookupName c = fmap fromProposedAccepted $ lookupName c = fmap fromProposedAccepted $
M.lookup nameField c <|> M.lookup sameasNameField c M.lookup nameField c <|> M.lookup sameasNameField c
instance RemoteNameable RemoteConfig where
getRemoteName c = fromMaybe "" (lookupName c)
{- The uuid that a sameas remote is the same as is stored in this key. -} {- The uuid that a sameas remote is the same as is stored in this key. -}
sameasUUIDField :: RemoteConfigField sameasUUIDField :: RemoteConfigField
sameasUUIDField = Accepted "sameas-uuid" sameasUUIDField = Accepted "sameas-uuid"
@ -75,6 +86,22 @@ exportTreeField = Accepted "exporttree"
importTreeField :: RemoteConfigField importTreeField :: RemoteConfigField
importTreeField = Accepted "importtree" importTreeField = Accepted "importtree"
exportTree :: ParsedRemoteConfig -> Bool
exportTree = fromMaybe False . getRemoteConfigValue exportTreeField
importTree :: ParsedRemoteConfig -> Bool
importTree = fromMaybe False . getRemoteConfigValue importTreeField
{- Parsers for fields that are common to all special remotes. -}
commonFieldsParser :: [RemoteConfigParser]
commonFieldsParser =
[ optionalStringParser nameField
, optionalStringParser sameasNameField
, optionalStringParser sameasUUIDField
, optionalStringParser typeField
, trueFalseParser autoEnableField False
]
{- A remote with sameas-uuid set will inherit these values from the config {- 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. -} - of that uuid. These values cannot be overridden in the remote's config. -}
sameasInherits :: S.Set RemoteConfigField sameasInherits :: S.Set RemoteConfigField
@ -124,3 +151,63 @@ findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toLis
sameasuuid (u, c) = case M.lookup sameasUUIDField c of sameasuuid (u, c) = case M.lookup sameasUUIDField c of
Nothing -> (u, c, Nothing) Nothing -> (u, c, Nothing)
Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u)) Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u))
{- Extracts a value from ParsedRemoteConfig. -}
getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v
getRemoteConfigValue f m = case M.lookup f m of
Just (RemoteConfigValue v) -> case cast v of
Just v' -> Just v'
Nothing -> error $ unwords
[ "getRemoteConfigValue"
, fromProposedAccepted f
, "found value of unexpected type"
, show (typeOf v) ++ "."
, "This is a bug in git-annex!"
]
Nothing -> Nothing
parseRemoteConfig :: RemoteConfig -> [RemoteConfigParser] -> Either String ParsedRemoteConfig
parseRemoteConfig c ps =
go [] (M.filterWithKey notaccepted c) (ps ++ commonFieldsParser)
where
go l c' []
| M.null c' = Right (M.fromList l)
| otherwise = Left $ "Unexpected fields: " ++
unwords (map fromProposedAccepted (M.keys c'))
go l c' ((f, p):rest) = do
v <- p (M.lookup f c) c
case v of
Just v' -> go ((f,v'):l) (M.delete f c') rest
Nothing -> go l (M.delete f c') rest
notaccepted (Proposed _) _ = True
notaccepted (Accepted _) _ = False
optionalStringParser :: RemoteConfigField -> RemoteConfigParser
optionalStringParser f = (f, p)
where
p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v)))
p Nothing _c = Right Nothing
yesNoParser :: RemoteConfigField -> Bool -> RemoteConfigParser
yesNoParser = genParser yesNo "yes or no"
trueFalseParser :: RemoteConfigField -> Bool -> RemoteConfigParser
trueFalseParser = genParser Git.Config.isTrueFalse "true or false"
genParser
:: Typeable t
=> (String -> Maybe t)
-> String -- ^ description of the value
-> RemoteConfigField
-> t -- ^ fallback value
-> RemoteConfigParser
genParser parse desc f fallback = (f, p)
where
p Nothing _c = Right (Just (RemoteConfigValue fallback))
p (Just v) _c = case parse (fromProposedAccepted v) of
Just b -> Right (Just (RemoteConfigValue b))
Nothing -> case v of
Accepted _ -> Right (Just (RemoteConfigValue fallback))
Proposed _ -> Left $
"Bad value for " ++ fromProposedAccepted f ++
" (expected " ++ desc ++ ")"

1
Command/Sync.hs
View file

@ -43,6 +43,7 @@ import Git.FilePath
import qualified Remote.Git import qualified Remote.Git
import Config import Config
import Config.GitConfig import Config.GitConfig
import Annex.SpecialRemote.Config
import Config.DynamicConfig import Config.DynamicConfig
import Config.Files import Config.Files
import Annex.Wanted import Annex.Wanted

22
Command/TestRemote.hs
View file

@ -1,6 +1,6 @@
{- git-annex command {- git-annex command
- -
- Copyright 2014-2019 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.
-} -}
@ -25,8 +25,11 @@ import Utility.CopyFile
import Types.Messages import Types.Messages
import Types.Export import Types.Export
import Types.ProposedAccepted import Types.ProposedAccepted
import Types.Crypto
import Types.RemoteConfig
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Remote.Helper.Chunked import Remote.Helper.Chunked
import Remote.Helper.Encryptable (describeEncryption)
import Git.Types import Git.Types
import Test.Tasty import Test.Tasty
@ -110,7 +113,7 @@ perform rs unavailrs exportr ks = do
desc r' k = intercalate "; " $ map unwords desc r' k = intercalate "; " $ map unwords
[ [ "key size", show (fromKey keySize k) ] [ [ "key size", show (fromKey keySize k) ]
, [ show (getChunkConfig (Remote.config r')) ] , [ show (getChunkConfig (Remote.config r')) ]
, ["encryption", maybe "none" fromProposedAccepted (M.lookup (Accepted "encryption") (Remote.config r'))] , ["encryption", describeEncryption (Remote.config r')]
] ]
descexport k1 k2 = intercalate "; " $ map unwords descexport k1 k2 = intercalate "; " $ map unwords
[ [ "exporttree=yes" ] [ [ "exporttree=yes" ]
@ -120,16 +123,17 @@ perform rs unavailrs exportr ks = do
adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)
adjustChunkSize r chunksize = adjustRemoteConfig r adjustChunkSize r chunksize = adjustRemoteConfig r
(M.insert (Proposed "chunk") (Proposed (show chunksize))) (M.insert (Proposed "chunk") (RemoteConfigValue (show chunksize)))
-- Variants of a remote with no encryption, and with simple shared -- Variants of a remote with no encryption, and with simple shared
-- encryption. Gpg key based encryption is not tested. -- encryption. Gpg key based encryption is not tested.
encryptionVariants :: Remote -> Annex [Remote] encryptionVariants :: Remote -> Annex [Remote]
encryptionVariants r = do encryptionVariants r = do
noenc <- adjustRemoteConfig r (M.insert (Proposed "encryption") (Proposed "none")) noenc <- adjustRemoteConfig r $
M.insert (Proposed "encryption") (RemoteConfigValue NoneEncryption)
sharedenc <- adjustRemoteConfig r $ sharedenc <- adjustRemoteConfig r $
M.insert (Proposed "encryption") (Proposed "shared") . M.insert (Proposed "encryption") (RemoteConfigValue SharedEncryption) .
M.insert (Proposed "highRandomQuality") (Proposed "false") M.insert (Proposed "highRandomQuality") (RemoteConfigValue False)
return $ catMaybes [noenc, sharedenc] return $ catMaybes [noenc, sharedenc]
-- Variant of a remote with exporttree disabled. -- Variant of a remote with exporttree disabled.
@ -141,13 +145,13 @@ disableExportTree r = maybe (error "failed disabling exportree") return
exportTreeVariant :: Remote -> Annex (Maybe Remote) exportTreeVariant :: Remote -> Annex (Maybe Remote)
exportTreeVariant r = ifM (Remote.isExportSupported r) exportTreeVariant r = ifM (Remote.isExportSupported r)
( adjustRemoteConfig r $ ( adjustRemoteConfig r $
M.insert (Proposed "encryption") (Proposed "none") . M.insert (Proposed "encryption") (RemoteConfigValue NoneEncryption) .
M.insert (Proposed "exporttree") (Proposed "yes") M.insert (Proposed "exporttree") (RemoteConfigValue True)
, return Nothing , return Nothing
) )
-- Regenerate a remote with a modified config. -- Regenerate a remote with a modified config.
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote) adjustRemoteConfig :: Remote -> (Remote.ParsedRemoteConfig -> Remote.ParsedRemoteConfig) -> Annex (Maybe Remote)
adjustRemoteConfig r adjustconfig = do adjustRemoteConfig r adjustconfig = do
repo <- Remote.getRepo r repo <- Remote.getRepo r
Remote.generate (Remote.remotetype r) Remote.generate (Remote.remotetype r)

14
Config.hs
View file

@ -20,10 +20,7 @@ import Config.DynamicConfig
import Types.Availability import Types.Availability
import Git.Types import Git.Types
import qualified Types.Remote as Remote 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 import qualified Data.ByteString as S
type UnqualifiedConfigKey = S.ByteString type UnqualifiedConfigKey = S.ByteString
@ -65,9 +62,6 @@ instance RemoteNameable RemoteName where
instance RemoteNameable Remote where instance RemoteNameable Remote where
getRemoteName = Remote.name getRemoteName = Remote.name
instance RemoteNameable Remote.RemoteConfig where
getRemoteName c = fromMaybe "" (SpecialRemote.lookupName c)
{- A per-remote config setting in git config. -} {- A per-remote config setting in git config. -}
remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
remoteConfig r key = ConfigKey $ remoteConfig r key = ConfigKey $
@ -112,14 +106,6 @@ setCrippledFileSystem b = do
setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = 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 :: String -> Maybe Bool
yesNo "yes" = Just True yesNo "yes" = Just True
yesNo "no" = Just False yesNo "no" = Just False

44
Config/RemoteConfig.hs
View file

@ -1,44 +0,0 @@
{- 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))

2
Creds.hs
View file

@ -24,7 +24,7 @@ import Annex.Common
import qualified Annex import qualified Annex
import Types.Creds import Types.Creds
import Types.RemoteConfig import Types.RemoteConfig
import Config.RemoteConfig import Annex.SpecialRemote.Config
import Annex.Perms import Annex.Perms
import Utility.FileMode import Utility.FileMode
import Crypto import Crypto

9
Crypto.hs
View file

@ -39,7 +39,6 @@ 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 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
@ -48,14 +47,6 @@ import Types.Remote
import Types.Key import Types.Key
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

15
Remote/Directory.hs
View file

@ -1,6 +1,6 @@
{- A "remote" that is just a filesystem directory. {- A "remote" that is just a filesystem directory.
- -
- 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.
-} -}
@ -24,6 +24,7 @@ import Types.Creds
import qualified Git import qualified Git
import Config.Cost import Config.Cost
import Config import Config
import Annex.SpecialRemote.Config
import Utility.FileMode import Utility.FileMode
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
@ -37,16 +38,20 @@ import Utility.InodeCache
import Types.ProposedAccepted import Types.ProposedAccepted
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "directory" { typename = "directory"
, enumerate = const (findSpecialRemotes "directory") , enumerate = const (findSpecialRemotes "directory")
, generate = gen , generate = gen
, configParser = [optionalStringParser directoryField]
, setup = directorySetup , setup = directorySetup
, exportSupported = exportIsSupported , exportSupported = exportIsSupported
, importSupported = importIsSupported , importSupported = importIsSupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) directoryField :: RemoteConfigField
directoryField = Accepted "directory"
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do gen r u c gc rs = do
cst <- remoteCost gc cheapRemoteCost cst <- remoteCost gc cheapRemoteCost
let chunkconfig = getChunkConfig c let chunkconfig = getChunkConfig c
@ -113,7 +118,7 @@ directorySetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane -- verify configuration is sane
let dir = maybe (giveup "Specify directory=") fromProposedAccepted $ let dir = maybe (giveup "Specify directory=") fromProposedAccepted $
M.lookup (Accepted "directory") c M.lookup directoryField c
absdir <- liftIO $ absPath dir absdir <- liftIO $ absPath dir
liftIO $ unlessM (doesDirectoryExist absdir) $ liftIO $ unlessM (doesDirectoryExist absdir) $
giveup $ "Directory does not exist: " ++ absdir giveup $ "Directory does not exist: " ++ absdir
@ -122,7 +127,7 @@ directorySetup _ mu _ c gc = do
-- The directory is stored in git config, not in this remote's -- The directory is stored in git config, not in this remote's
-- persistant state, so it can vary between hosts. -- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c' [("directory", absdir)] gitConfigSpecialRemote u c' [("directory", absdir)]
return (M.delete (Accepted "directory") c', u) return (M.delete directoryField c', u)
{- Locations to try to access a given Key in the directory. {- Locations to try to access a given Key in the directory.
- We try more than one since we used to write to different hash - We try more than one since we used to write to different hash

27
Remote/GCrypt.hs
View file

@ -39,6 +39,7 @@ import qualified Git.Construct
import qualified Annex.Branch import qualified Annex.Branch
import Config import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Git import Remote.Helper.Git
import Remote.Helper.Encryptable import Remote.Helper.Encryptable
import Remote.Helper.Special import Remote.Helper.Special
@ -59,18 +60,22 @@ import Messages.Progress
import Types.ProposedAccepted import Types.ProposedAccepted
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "gcrypt" { typename = "gcrypt"
-- Remote.Git takes care of enumerating gcrypt remotes too, -- Remote.Git takes care of enumerating gcrypt remotes too,
-- and will call our gen on them. -- and will call our gen on them.
, enumerate = const (return []) , enumerate = const (return [])
, generate = gen , generate = gen
, configParser = [optionalStringParser gitRepoField]
, setup = gCryptSetup , setup = gCryptSetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , importSupported = importUnsupported
} }
chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gitRepoField :: RemoteConfigField
gitRepoField = Accepted "gitrepo"
chainGen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
chainGen gcryptr u c gc rs = do chainGen gcryptr u c gc rs = do
g <- gitRepo g <- gitRepo
-- get underlying git repo with real path, not gcrypt path -- get underlying git repo with real path, not gcrypt path
@ -78,7 +83,7 @@ chainGen gcryptr u c gc rs = do
let r' = r { Git.remoteName = Git.remoteName gcryptr } let r' = r { Git.remoteName = Git.remoteName gcryptr }
gen r' u c gc rs gen r' u c gc rs
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen baser u c gc rs = do gen baser u c gc rs = do
-- doublecheck that cache matches underlying repo's gcrypt-id -- doublecheck that cache matches underlying repo's gcrypt-id
-- (which might not be set), only for local repos -- (which might not be set), only for local repos
@ -99,15 +104,17 @@ gen baser u c gc rs = do
v <- M.lookup u' <$> readRemoteLog v <- M.lookup u' <$> readRemoteLog
case (Git.remoteName baser, v) of case (Git.remoteName baser, v) of
(Just remotename, Just c') -> do (Just remotename, Just c') -> do
setGcryptEncryption c' remotename pc <- either giveup return $
parseRemoteConfig c' (configParser remote)
setGcryptEncryption pc remotename
storeUUIDIn (remoteConfig baser "uuid") u' storeUUIDIn (remoteConfig baser "uuid") u'
setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
gen' r u' c' gc rs gen' r u' pc gc rs
_ -> do _ -> do
warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r
return Nothing return Nothing
gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen' r u c gc rs = do gen' r u c gc rs = do
cst <- remoteCost gc $ cst <- remoteCost gc $
if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost
@ -188,7 +195,7 @@ unsupportedUrl :: a
unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not supported" 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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup (Accepted "gitrepo") c gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c
where where
remotename = fromJust (lookupName c) remotename = fromJust (lookupName c)
go Nothing = giveup "Specify gitrepo=" go Nothing = giveup "Specify gitrepo="
@ -207,7 +214,9 @@ gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup (Accepted "gitr
| Git.repoLocation r == url -> noop | Git.repoLocation r == url -> noop
| otherwise -> error "Another remote with the same name already exists." | otherwise -> error "Another remote with the same name already exists."
setGcryptEncryption c' remotename pc <- either giveup return $
parseRemoteConfig c' (configParser remote)
setGcryptEncryption pc remotename
{- Run a git fetch and a push to the git repo in order to get {- Run a git fetch and a push to the git repo in order to get
- its gcrypt-id set up, so that later git annex commands - its gcrypt-id set up, so that later git annex commands
@ -323,7 +332,7 @@ shellOrRsync r ashell arsync
- Also, sets gcrypt-publish-participants to avoid unncessary gpg - Also, sets gcrypt-publish-participants to avoid unncessary gpg
- passphrase prompts. - passphrase prompts.
-} -}
setGcryptEncryption :: RemoteConfig -> String -> Annex () setGcryptEncryption :: ParsedRemoteConfig -> String -> Annex ()
setGcryptEncryption c remotename = do setGcryptEncryption c remotename = do
let participants = remoteconfig Git.GCrypt.remoteParticipantConfigKey let participants = remoteconfig Git.GCrypt.remoteParticipantConfigKey
case extractCipher c of case extractCipher c of

13
Remote/Git.hs
View file

@ -37,6 +37,7 @@ import qualified Annex.SpecialRemote.Config as SpecialRemote
import Utility.Tmp import Utility.Tmp
import Config import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config
import Config.DynamicConfig import Config.DynamicConfig
import Annex.Init import Annex.Init
import Types.CleanupActions import Types.CleanupActions
@ -79,11 +80,15 @@ remote = RemoteType
{ typename = "git" { typename = "git"
, enumerate = list , enumerate = list
, generate = gen , generate = gen
, configParser = [optionalStringParser locationField]
, setup = gitSetup , setup = gitSetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , importSupported = importUnsupported
} }
locationField :: RemoteConfigField
locationField = Accepted "location"
list :: Bool -> Annex [Git.Repo] list :: Bool -> Annex [Git.Repo]
list autoinit = do list autoinit = do
c <- fromRepo Git.config c <- fromRepo Git.config
@ -113,7 +118,7 @@ gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remote
gitSetup Init mu _ c _ = do gitSetup Init mu _ c _ = do
let location = fromMaybe (giveup "Specify location=url") $ let location = fromMaybe (giveup "Specify location=url") $
Url.parseURIRelaxed . fromProposedAccepted Url.parseURIRelaxed . fromProposedAccepted
=<< M.lookup (Accepted "location") c =<< M.lookup locationField c
rs <- Annex.getGitRemotes rs <- Annex.getGitRemotes
u <- case filter (\r -> Git.location r == Git.Url location) rs of u <- case filter (\r -> Git.location r == Git.Url location) rs of
[r] -> getRepoUUID r [r] -> getRepoUUID r
@ -127,7 +132,7 @@ gitSetup (Enable _) (Just u) _ c _ = do
[ Param "remote" [ Param "remote"
, Param "add" , Param "add"
, Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c) , Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c)
, Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup (Accepted "location") c) , Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c)
] ]
return (c, u) return (c, u)
gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid" gitSetup (Enable _) Nothing _ _ _ = error "unable to enable git remote with no specified uuid"
@ -153,7 +158,7 @@ configRead autoinit r = do
Just r' -> return r' Just r' -> return r'
_ -> return r _ -> return r
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs gen r u c gc rs
-- Remote.GitLFS may be used with a repo that is also encrypted -- Remote.GitLFS may be used with a repo that is also encrypted
-- with gcrypt so is checked first. -- with gcrypt so is checked first.
@ -204,7 +209,7 @@ gen r u c gc rs
, remoteStateHandle = rs , remoteStateHandle = rs
} }
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) unavailable :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
unavailable r = gen r' unavailable r = gen r'
where where
r' = case Git.location r of r' = case Git.location r of

20
Remote/GitLFS.hs
View file

@ -1,6 +1,6 @@
{- Using git-lfs as a remote. {- Using git-lfs as a remote.
- -
- Copyright 2019 Joey Hess <id@joeyh.name> - Copyright 2019-2020 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -25,6 +25,7 @@ import qualified Git.GCrypt
import qualified Git.Credential as Git import qualified Git.Credential as Git
import Config import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Remote.Helper.Git import Remote.Helper.Git
@ -53,18 +54,22 @@ import qualified Data.Text.Encoding as E
import qualified Control.Concurrent.MSemN as MSemN import qualified Control.Concurrent.MSemN as MSemN
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "git-lfs" { typename = "git-lfs"
-- Remote.Git takes care of enumerating git-lfs remotes too, -- Remote.Git takes care of enumerating git-lfs remotes too,
-- and will call our gen on them. -- and will call our gen on them.
, enumerate = const (return []) , enumerate = const (return [])
, generate = gen , generate = gen
, configParser = [optionalStringParser urlField]
, setup = mySetup , setup = mySetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) urlField :: RemoteConfigField
urlField = Accepted "url"
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do gen r u c gc rs = do
-- If the repo uses gcrypt, get the underlaying repo without the -- If the repo uses gcrypt, get the underlaying repo without the
-- gcrypt url, to do LFS endpoint discovery on. -- gcrypt url, to do LFS endpoint discovery on.
@ -128,9 +133,10 @@ mySetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc
case (isEncrypted c', Git.GCrypt.urlPrefix `isPrefixOf` url) of pc <- either giveup return $ parseRemoteConfig c' (configParser remote)
case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of
(False, False) -> noop (False, False) -> noop
(True, True) -> Remote.GCrypt.setGcryptEncryption c' remotename (True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename
(True, False) -> unlessM (Annex.getState Annex.force) $ (True, False) -> unlessM (Annex.getState Annex.force) $
giveup $ unwords $ giveup $ unwords $
[ "Encryption is enabled for this remote," [ "Encryption is enabled for this remote,"
@ -160,7 +166,7 @@ mySetup _ mu _ c gc = do
return (c', u) return (c', u)
where where
url = maybe (giveup "Specify url=") fromProposedAccepted url = maybe (giveup "Specify url=") fromProposedAccepted
(M.lookup (Accepted "url") c) (M.lookup urlField c)
remotename = fromJust (lookupName c) remotename = fromJust (lookupName c)
{- Check if a remote's url is one known to belong to a git-lfs repository. {- Check if a remote's url is one known to belong to a git-lfs repository.
@ -180,7 +186,7 @@ configKnownUrl r
t <- fromProposedAccepted t <- fromProposedAccepted
<$> M.lookup Annex.SpecialRemote.Config.typeField c <$> M.lookup Annex.SpecialRemote.Config.typeField c
u <- fromProposedAccepted u <- fromProposedAccepted
<$> M.lookup (Accepted "url") c <$> M.lookup urlField c
let u' = Git.Remote.parseRemoteLocation u g let u' = Git.Remote.parseRemoteLocation u g
return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u' return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u'
&& t == typename remote && t == typename remote

5
Remote/Helper/Chunked.hs
View file

@ -28,7 +28,6 @@ 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
@ -52,8 +51,8 @@ noChunks _ = False
chunkConfigParser :: [RemoteConfigParser] chunkConfigParser :: [RemoteConfigParser]
chunkConfigParser = chunkConfigParser =
[ optStringParser chunksizeField [ optionalStringParser chunksizeField
, optStringParser chunkField , optionalStringParser chunkField
] ]
getChunkConfig :: ParsedRemoteConfig -> ChunkConfig getChunkConfig :: ParsedRemoteConfig -> ChunkConfig

32
Remote/Helper/Encryptable.hs
View file

@ -13,6 +13,7 @@ module Remote.Helper.Encryptable (
noEncryptionUsed, noEncryptionUsed,
encryptionAlreadySetup, encryptionAlreadySetup,
encryptionConfigParser, encryptionConfigParser,
parseEncryptionConfig,
remoteCipher, remoteCipher,
remoteCipher', remoteCipher',
embedCreds, embedCreds,
@ -23,12 +24,12 @@ module Remote.Helper.Encryptable (
) where ) where
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S
import qualified "sandi" Codec.Binary.Base64 as B64 import qualified "sandi" Codec.Binary.Base64 as B64
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Annex.Common import Annex.Common
import Types.Remote import Types.Remote
import Config.RemoteConfig
import Crypto import Crypto
import Types.Crypto import Types.Crypto
import Types.ProposedAccepted import Types.ProposedAccepted
@ -52,18 +53,25 @@ encryptionAlreadySetup = EncryptionIsSetup
encryptionConfigParser :: [RemoteConfigParser] encryptionConfigParser :: [RemoteConfigParser]
encryptionConfigParser = encryptionConfigParser =
[ (encryptionField, \v c -> RemoteConfigValue <$> parseEncryptionMethod (fmap fromProposedAccepted v) c) [ (encryptionField, \v c -> Just . RemoteConfigValue <$> parseEncryptionMethod (fmap fromProposedAccepted v) c)
, optStringParser cipherField , optionalStringParser cipherField
, optStringParser cipherkeysField , optionalStringParser cipherkeysField
, optStringParser pubkeysField , optionalStringParser pubkeysField
, yesNoParser embedCredsField False , yesNoParser embedCredsField False
, (macField, \v _c -> RemoteConfigValue <$> parseMac v) , (macField, \v _c -> Just . RemoteConfigValue <$> parseMac v)
, optStringParser (Accepted "keyid") , optionalStringParser (Accepted "keyid")
, optStringParser (Accepted "keyid+") , optionalStringParser (Accepted "keyid+")
, optStringParser (Accepted "keyid-") , optionalStringParser (Accepted "keyid-")
, (Accepted "highRandomQuality", \v _c -> RemoteConfigValue <$> parseHighRandomQuality (fmap fromProposedAccepted v)) , (Accepted "highRandomQuality", \v _c -> Just . RemoteConfigValue <$> parseHighRandomQuality (fmap fromProposedAccepted v))
] ]
encryptionConfigs :: S.Set RemoteConfigField
encryptionConfigs = S.fromList (map fst encryptionConfigParser)
-- Parse only encryption fields, ignoring all others.
parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig
parseEncryptionConfig c = parseRemoteConfig (M.restrictKeys c encryptionConfigs) encryptionConfigParser
parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod
parseEncryptionMethod (Just "none") _ = Right NoneEncryption parseEncryptionMethod (Just "none") _ = Right NoneEncryption
parseEncryptionMethod (Just "shared") _ = Right SharedEncryption parseEncryptionMethod (Just "shared") _ = Right SharedEncryption
@ -100,7 +108,7 @@ parseMac (Just (Proposed s)) = case readMac s of
- could opt to use a shared cipher, which is stored unencrypted. -} - 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 pc <- either giveup return $ parseEncryptionConfig c
cmd <- gpgCmd <$> Annex.getGitConfig cmd <- gpgCmd <$> Annex.getGitConfig
maybe (genCipher pc cmd) (updateCipher pc cmd) (extractCipher pc) maybe (genCipher pc cmd) (updateCipher pc cmd) (extractCipher pc)
where where
@ -228,7 +236,7 @@ isEncrypted = isJust . extractCipher
describeEncryption :: ParsedRemoteConfig -> String describeEncryption :: ParsedRemoteConfig -> String
describeEncryption c = case extractCipher c of describeEncryption c = case extractCipher c of
Nothing -> "none" Nothing -> "none" ++ show (getRemoteConfigValue cipherField c :: Maybe String) ++ show (M.keys c)
Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")" Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")"
nameCipher :: StorableCipher -> String nameCipher :: StorableCipher -> String

77
Remote/Helper/ExportImport.hs
View file

@ -20,20 +20,18 @@ import qualified Database.Export as Export
import qualified Database.ContentIdentifier as ContentIdentifier import qualified Database.ContentIdentifier as ContentIdentifier
import Annex.Export import Annex.Export
import Annex.LockFile import Annex.LockFile
import Config import Annex.SpecialRemote.Config
import Annex.SpecialRemote.Config (exportTreeField, importTreeField)
import Git.Types (fromRef) import Git.Types (fromRef)
import Logs.Export import Logs.Export
import Logs.ContentIdentifier (recordContentIdentifier) import Logs.ContentIdentifier (recordContentIdentifier)
import qualified Data.Map as M
import Control.Concurrent.STM import Control.Concurrent.STM
-- | Use for remotes that do not support exports. -- | Use for remotes that do not support exports.
class HasExportUnsupported a where class HasExportUnsupported a where
exportUnsupported :: a exportUnsupported :: a
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where instance HasExportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where
exportUnsupported = \_ _ -> return False exportUnsupported = \_ _ -> return False
instance HasExportUnsupported (ExportActions Annex) where instance HasExportUnsupported (ExportActions Annex) where
@ -52,7 +50,7 @@ instance HasExportUnsupported (ExportActions Annex) where
class HasImportUnsupported a where class HasImportUnsupported a where
importUnsupported :: a importUnsupported :: a
instance HasImportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where instance HasImportUnsupported (ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool) where
importUnsupported = \_ _ -> return False importUnsupported = \_ _ -> return False
instance HasImportUnsupported (ImportActions Annex) where instance HasImportUnsupported (ImportActions Annex) where
@ -65,62 +63,67 @@ instance HasImportUnsupported (ImportActions Annex) where
, checkPresentExportWithContentIdentifier = \_ _ _ -> return False , checkPresentExportWithContentIdentifier = \_ _ _ -> return False
} }
exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool exportIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool
exportIsSupported = \_ _ -> return True exportIsSupported = \_ _ -> return True
importIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool importIsSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool
importIsSupported = \_ _ -> return True importIsSupported = \_ _ -> return True
-- | Prevent or allow exporttree=yes and importtree=yes when -- | Prevent or allow exporttree=yes and importtree=yes when
-- setting up a new remote, depending on exportSupported and importSupported. -- setting up a new remote, depending on exportSupported and importSupported.
adjustExportImportRemoteType :: RemoteType -> RemoteType adjustExportImportRemoteType :: RemoteType -> RemoteType
adjustExportImportRemoteType rt = rt { setup = setup' } adjustExportImportRemoteType rt = rt
{ setup = setup'
, configParser = configparser
}
where where
setup' st mu cp c gc = configparser = configParser rt ++ exportImportConfigParser
let checkconfig supported configured configfield cont = do setup' st mu cp c gc = do
case parseProposedAccepted configfield c yesNo False "yes or no" of pc <- either giveup return $ parseRemoteConfig c configparser
Right _ -> noop let checkconfig supported configured configfield cont =
Left err -> giveup err ifM (supported rt pc gc)
ifM (supported rt c gc)
( case st of ( case st of
Init Init
| configured c && isEncrypted c -> | configured pc && isEncrypted pc ->
giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield
| otherwise -> cont | otherwise -> cont
Enable oldc Enable oldc ->
| configured c /= configured oldc -> let oldpc = either mempty id $ parseRemoteConfig oldc configparser
giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote" in if configured pc /= configured oldpc
| otherwise -> cont then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote"
, if configured c else cont
, if configured pc
then giveup $ fromProposedAccepted configfield ++ " is not supported by this special remote" then giveup $ fromProposedAccepted configfield ++ " is not supported by this special remote"
else cont else cont
) )
in checkconfig exportSupported exportTree exportTreeField $ checkconfig exportSupported exportTree exportTreeField $
checkconfig importSupported importTree importTreeField $ checkconfig importSupported importTree importTreeField $
if importTree c && not (exportTree c) if importTree pc && not (exportTree pc)
then giveup "cannot enable importtree=yes without also enabling exporttree=yes" then giveup "cannot enable importtree=yes without also enabling exporttree=yes"
else setup rt st mu cp c gc else setup rt st mu cp c gc
exportImportConfigParser :: [RemoteConfigParser]
exportImportConfigParser =
[ yesNoParser exportTreeField False
, yesNoParser importTreeField False
]
-- | Adjust a remote to support exporttree=yes and importree=yes. -- | Adjust a remote to support exporttree=yes and importree=yes.
-- --
-- Note that all remotes with importree=yes also have exporttree=yes. -- Note that all remotes with importree=yes also have exporttree=yes.
adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote
adjustExportImport r rs = case M.lookup exportTreeField (config r) of adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) of
Nothing -> return $ notexport r Nothing -> return $ notexport r
Just c -> case yesNo (fromProposedAccepted c) of Just True -> ifM (isExportSupported r)
Just True -> ifM (isExportSupported r) ( do
( do exportdbv <- prepexportdb
exportdbv <- prepexportdb r' <- isexport exportdbv
r' <- isexport exportdbv if importTree (config r)
if importTree (config r) then isimport r' exportdbv
then isimport r' exportdbv else return r'
else return r' , return $ notexport r
, return $ notexport r )
) Just False -> return $ notexport r
Just False -> return $ notexport r
Nothing -> do
warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export"
return $ notexport r
where where
notexport r' = notimport r' notexport r' = notimport r'
{ exportActions = exportUnsupported { exportActions = exportUnsupported

13
Remote/Helper/Special.hs
View file

@ -31,6 +31,7 @@ module Remote.Helper.Special (
specialRemoteConfigParser, specialRemoteConfigParser,
SpecialRemoteCfg(..), SpecialRemoteCfg(..),
specialRemoteCfg, specialRemoteCfg,
specialRemoteType,
specialRemote, specialRemote,
specialRemote', specialRemote',
lookupName, lookupName,
@ -158,9 +159,6 @@ 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
@ -169,6 +167,15 @@ data SpecialRemoteCfg = SpecialRemoteCfg
specialRemoteCfg :: ParsedRemoteConfig -> SpecialRemoteCfg specialRemoteCfg :: ParsedRemoteConfig -> SpecialRemoteCfg
specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True
-- Modifies a base RemoteType to support chunking and encryption configs.
specialRemoteType :: RemoteType -> RemoteType
specialRemoteType r = r
{ configParser = configParser r ++ specialRemoteConfigParser
}
specialRemoteConfigParser :: [RemoteConfigParser]
specialRemoteConfigParser = chunkConfigParser ++ encryptionConfigParser
-- Modifies a base Remote to support both chunking and encryption, -- Modifies a base Remote to support both chunking and encryption,
-- which special remotes typically should support. -- which special remotes typically should support.
-- --

18
Remote/List.hs
View file

@ -1,6 +1,6 @@
{- git-annex remote list {- git-annex remote list
- -
- 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.
-} -}
@ -20,17 +20,21 @@ import Annex.UUID
import Remote.Helper.Hooks import Remote.Helper.Hooks
import Remote.Helper.ReadOnly import Remote.Helper.ReadOnly
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Annex.SpecialRemote.Config
import qualified Git import qualified Git
import qualified Git.Config import qualified Git.Config
import qualified Remote.Git import qualified Remote.Git
import qualified Remote.GCrypt import qualified Remote.GCrypt
import qualified Remote.P2P import qualified Remote.P2P
{-
#ifdef WITH_S3 #ifdef WITH_S3
import qualified Remote.S3 import qualified Remote.S3
#endif #endif
import qualified Remote.Bup import qualified Remote.Bup
-}
import qualified Remote.Directory import qualified Remote.Directory
{-
import qualified Remote.Rsync import qualified Remote.Rsync
import qualified Remote.Web import qualified Remote.Web
import qualified Remote.BitTorrent import qualified Remote.BitTorrent
@ -41,20 +45,26 @@ import qualified Remote.Adb
import qualified Remote.Tahoe import qualified Remote.Tahoe
import qualified Remote.Glacier import qualified Remote.Glacier
import qualified Remote.Ddar import qualified Remote.Ddar
-}
import qualified Remote.GitLFS import qualified Remote.GitLFS
{-
import qualified Remote.Hook import qualified Remote.Hook
import qualified Remote.External import qualified Remote.External
-}
remoteTypes :: [RemoteType] remoteTypes :: [RemoteType]
remoteTypes = map adjustExportImportRemoteType remoteTypes = map adjustExportImportRemoteType
[ Remote.Git.remote [ Remote.Git.remote
, Remote.GCrypt.remote , Remote.GCrypt.remote
, Remote.P2P.remote , Remote.P2P.remote
{-
#ifdef WITH_S3 #ifdef WITH_S3
, Remote.S3.remote , Remote.S3.remote
#endif #endif
, Remote.Bup.remote , Remote.Bup.remote
-}
, Remote.Directory.remote , Remote.Directory.remote
{-
, Remote.Rsync.remote , Remote.Rsync.remote
, Remote.Web.remote , Remote.Web.remote
, Remote.BitTorrent.remote , Remote.BitTorrent.remote
@ -65,9 +75,12 @@ remoteTypes = map adjustExportImportRemoteType
, Remote.Tahoe.remote , Remote.Tahoe.remote
, Remote.Glacier.remote , Remote.Glacier.remote
, Remote.Ddar.remote , Remote.Ddar.remote
-}
, Remote.GitLFS.remote , Remote.GitLFS.remote
{-
, Remote.Hook.remote , Remote.Hook.remote
, Remote.External.remote , Remote.External.remote
-}
] ]
{- Builds a list of all available Remotes. {- Builds a list of all available Remotes.
@ -109,7 +122,8 @@ remoteGen m t g = do
let cu = fromMaybe u $ remoteAnnexConfigUUID gc let cu = fromMaybe u $ remoteAnnexConfigUUID gc
let rs = RemoteStateHandle cu let rs = RemoteStateHandle cu
let c = fromMaybe M.empty $ M.lookup cu m let c = fromMaybe M.empty $ M.lookup cu m
generate t g u c gc rs >>= \case let pc = either mempty id (parseRemoteConfig c (configParser t))
generate t g u pc gc rs >>= \case
Nothing -> return Nothing Nothing -> return Nothing
Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs

3
Remote/P2P.hs
View file

@ -36,12 +36,13 @@ remote = RemoteType
-- and will call chainGen on them. -- and will call chainGen on them.
, enumerate = const (return []) , enumerate = const (return [])
, generate = \_ _ _ _ _ -> return Nothing , generate = \_ _ _ _ _ -> return Nothing
, configParser = []
, setup = error "P2P remotes are set up using git-annex p2p" , setup = error "P2P remotes are set up using git-annex p2p"
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , importSupported = importUnsupported
} }
chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) chainGen :: P2PAddress -> Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
chainGen addr r u c gc rs = do chainGen addr r u c gc rs = do
connpool <- mkConnectionPool connpool <- mkConnectionPool
cst <- remoteCost gc veryExpensiveRemoteCost cst <- remoteCost gc veryExpensiveRemoteCost

26
Remote/Rsync.hs
View file

@ -1,6 +1,6 @@
{- A remote that is only accessible by rsync. {- A remote that is only accessible by rsync.
- -
- Copyright 2011-2018 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.
-} -}
@ -42,20 +42,31 @@ import Types.Creds
import Annex.DirHashes import Annex.DirHashes
import Utility.Tmp.Dir import Utility.Tmp.Dir
import Utility.SshHost import Utility.SshHost
import Annex.SpecialRemote.Config
import qualified Data.Map as M import qualified Data.Map as M
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "rsync" { typename = "rsync"
, enumerate = const (findSpecialRemotes "rsyncurl") , enumerate = const (findSpecialRemotes "rsyncurl")
, generate = gen , generate = gen
, configParser =
[ yesNoParser shellEscapeField True
, optionalStringParser rsyncUrlField
]
, setup = rsyncSetup , setup = rsyncSetup
, exportSupported = exportIsSupported , exportSupported = exportIsSupported
, importSupported = importUnsupported , importSupported = importUnsupported
} }
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) shellEscapeField :: RemoteConfigField
shellEscapeField = Accepted "shellescape"
rsyncUrlField :: RemoteConfigField
rsyncUrlField = Accepted "rsyncurl"
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
(transport, url) <- rsyncTransport gc $ (transport, url) <- rsyncTransport gc $
@ -112,7 +123,7 @@ gen r u c gc rs = do
-- Rsync displays its own progress. -- Rsync displays its own progress.
{ displayProgress = False } { displayProgress = False }
genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts genRsyncOpts :: ParsedRemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts
genRsyncOpts c gc transport url = RsyncOpts genRsyncOpts c gc transport url = RsyncOpts
{ rsyncUrl = url { rsyncUrl = url
, rsyncOptions = appendtransport $ opts [] , rsyncOptions = appendtransport $ opts []
@ -120,7 +131,7 @@ genRsyncOpts c gc transport url = RsyncOpts
opts (remoteAnnexRsyncUploadOptions gc) opts (remoteAnnexRsyncUploadOptions gc)
, rsyncDownloadOptions = appendtransport $ , rsyncDownloadOptions = appendtransport $
opts (remoteAnnexRsyncDownloadOptions gc) opts (remoteAnnexRsyncDownloadOptions gc)
, rsyncShellEscape = (yesNo . fromProposedAccepted =<< M.lookup (Accepted "shellescape") c) /= Just False , rsyncShellEscape = fromMaybe True (getRemoteConfigValue shellEscapeField c)
} }
where where
appendtransport l = (++ l) <$> transport appendtransport l = (++ l) <$> transport
@ -163,10 +174,7 @@ rsyncSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane -- verify configuration is sane
let url = maybe (giveup "Specify rsyncurl=") fromProposedAccepted $ let url = maybe (giveup "Specify rsyncurl=") fromProposedAccepted $
M.lookup (Accepted "rsyncurl") c M.lookup rsyncUrlField c
case parseProposedAccepted (Accepted "shellescape") c yesNo False "yes or no" of
Left err -> giveup err
_ -> noop
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc
-- The rsyncurl is stored in git config, not only in this remote's -- The rsyncurl is stored in git config, not only in this remote's

3
Remote/Web.hs
View file

@ -27,6 +27,7 @@ remote = RemoteType
{ typename = "web" { typename = "web"
, enumerate = list , enumerate = list
, generate = gen , generate = gen
, configParser = []
, setup = error "not supported" , setup = error "not supported"
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , importSupported = importUnsupported
@ -40,7 +41,7 @@ list _autoinit = do
r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown) r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown)
return [r] return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r _ c gc rs = do gen r _ c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just Remote return $ Just Remote

6
Test.hs
View file

@ -1614,7 +1614,7 @@ test_crypto = do
annexed_present annexedfile annexed_present annexedfile
{- Ensure the configuration complies with the encryption scheme, and {- Ensure the configuration complies with the encryption scheme, and
- that all keys are encrypted properly for the given directory remote. -} - that all keys are encrypted properly for the given directory remote. -}
testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher c of testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of
Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks -> Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks ->
checkKeys cip Nothing checkKeys cip Nothing
Just cip@(Crypto.EncryptedCipher encipher v ks') Just cip@(Crypto.EncryptedCipher encipher v ks')
@ -1622,6 +1622,8 @@ test_crypto = do
checkKeys cip (Just v) <&&> checkCipher encipher ks' checkKeys cip (Just v) <&&> checkCipher encipher ks'
_ -> return False _ -> return False
where where
pc =either mempty id $
Remote.Helper.Encryptable.parseEncryptionConfig c
keysMatch (Utility.Gpg.KeyIds ks') = keysMatch (Utility.Gpg.KeyIds ks') =
maybe False (\(Utility.Gpg.KeyIds ks2) -> maybe False (\(Utility.Gpg.KeyIds ks2) ->
sort (nub ks2) == sort (nub ks')) ks sort (nub ks2) == sort (nub ks')) ks
@ -1630,7 +1632,7 @@ test_crypto = do
checkScheme Types.Crypto.PubKey = scheme == "pubkey" checkScheme Types.Crypto.PubKey = scheme == "pubkey"
checkKeys cip mvariant = do checkKeys cip mvariant = do
dummycfg <- Types.GitConfig.dummyRemoteGitConfig dummycfg <- Types.GitConfig.dummyRemoteGitConfig
let encparams = (mempty :: Types.Remote.RemoteConfig, dummycfg) let encparams = (mempty :: Types.Remote.ParsedRemoteConfig, dummycfg)
cipher <- Crypto.decryptCipher gpgcmd encparams cip cipher <- Crypto.decryptCipher gpgcmd encparams cip
files <- filterM doesFileExist $ files <- filterM doesFileExist $
map ("dir" </>) $ concatMap (serializeKeys cipher) keys map ("dir" </>) $ concatMap (serializeKeys cipher) keys

13
Types/Crypto.hs
View file

@ -1,11 +1,12 @@
{- git-annex crypto types {- git-annex crypto types
- -
- Copyright 2011-2015 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.
-} -}
module Types.Crypto ( module Types.Crypto (
EncryptionMethod(..),
Cipher(..), Cipher(..),
StorableCipher(..), StorableCipher(..),
EncryptedCipherVariant(..), EncryptedCipherVariant(..),
@ -21,6 +22,16 @@ module Types.Crypto (
import Utility.Hash import Utility.Hash
import Utility.Gpg (KeyIds(..)) import Utility.Gpg (KeyIds(..))
import Data.Typeable
data EncryptionMethod
= NoneEncryption
| SharedEncryption
| PubKeyEncryption
| SharedPubKeyEncryption
| HybridEncryption
deriving (Typeable, Eq)
-- XXX ideally, this would be a locked memory region -- XXX ideally, this would be a locked memory region
data Cipher = Cipher String | MacOnlyCipher String data Cipher = Cipher String | MacOnlyCipher String

26
Types/ProposedAccepted.hs
View file

@ -7,7 +7,6 @@
module Types.ProposedAccepted where module Types.ProposedAccepted where
import qualified Data.Map as M
import Test.QuickCheck import Test.QuickCheck
-- | A value that may be proposed, or accepted. -- | A value that may be proposed, or accepted.
@ -37,28 +36,3 @@ instance Arbitrary t => Arbitrary (ProposedAccepted t) where
[ Proposed <$> arbitrary [ Proposed <$> arbitrary
, Accepted <$> 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)

4
Types/Remote.hs
View file

@ -57,10 +57,10 @@ 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]
-- generates a remote of this type
, generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
-- parse configs of remotes of this type -- parse configs of remotes of this type
, configParser :: [RemoteConfigParser] , configParser :: [RemoteConfigParser]
-- generates a remote of this type
, 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

8
Types/RemoteConfig.hs
View file

@ -28,12 +28,6 @@ type ParsedRemoteConfig = M.Map RemoteConfigField RemoteConfigValue
data RemoteConfigValue where data RemoteConfigValue where
RemoteConfigValue :: Typeable v => v -> RemoteConfigValue 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. {- Parse a field's value provided by the user into a RemoteConfigValue.
- -
- The RemoteConfig is provided to the parser function for cases - The RemoteConfig is provided to the parser function for cases
@ -43,4 +37,4 @@ getRemoteConfigValue f m = case M.lookup f m of
- Presence of fields that are not included in this list will cause - Presence of fields that are not included in this list will cause
- a parse failure. - a parse failure.
-} -}
type RemoteConfigParser = (RemoteConfigField, Maybe (ProposedAccepted String) -> RemoteConfig -> Either String RemoteConfigValue) type RemoteConfigParser = (RemoteConfigField, Maybe (ProposedAccepted String) -> RemoteConfig -> Either String (Maybe RemoteConfigValue))