Merge branch 'master' into v8

Types/Crypto.hs

@@ -1,11 +1,12 @@
 {- 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.
  -}
 
 module Types.Crypto (
+	EncryptionMethod(..),
 	Cipher(..),
 	StorableCipher(..),
 	EncryptedCipherVariant(..),
@@ -14,6 +15,7 @@ module Types.Crypto (
 	Mac(..),
 	readMac,
 	showMac,
+	macMap,
 	defaultMac,
 	calcMac,
 ) where
@@ -21,6 +23,17 @@ module Types.Crypto (
 import Utility.Hash
 import Utility.Gpg (KeyIds(..))
 
+import Data.Typeable
+import qualified Data.Map as M
+
+data EncryptionMethod
+	= NoneEncryption
+	| SharedEncryption
+	| PubKeyEncryption
+	| SharedPubKeyEncryption
+	| HybridEncryption
+	deriving (Typeable, Eq)
+
 -- XXX ideally, this would be a locked memory region
 data Cipher = Cipher String | MacOnlyCipher String
 
@@ -50,9 +63,13 @@ showMac HmacSha512 = "HMACSHA512"
 
 -- Read the MAC algorithm from the remote config.
 readMac :: String -> Maybe Mac
-readMac "HMACSHA1"   = Just HmacSha1
-readMac "HMACSHA224" = Just HmacSha224
-readMac "HMACSHA256" = Just HmacSha256
-readMac "HMACSHA384" = Just HmacSha384
-readMac "HMACSHA512" = Just HmacSha512
-readMac _ = Nothing
+readMac n = M.lookup n macMap
+
+macMap :: M.Map String Mac
+macMap = M.fromList
+	[ ("HMACSHA1", HmacSha1)
+	, ("HMACSHA224", HmacSha224)
+	, ("HMACSHA256", HmacSha256)
+	, ("HMACSHA384", HmacSha384)
+	, ("HMACSHA512", HmacSha512)
+	]

Types/GitConfig.hs

@@ -80,6 +80,7 @@ data GitConfig = GitConfig
 	, annexAutoCommit :: Configurable Bool
 	, annexResolveMerge :: Configurable Bool
 	, annexSyncContent :: Configurable Bool
+	, annexSyncOnlyAnnex :: Configurable Bool
 	, annexDebug :: Bool
 	, annexWebOptions :: [String]
 	, annexYoutubeDlOptions :: [String]
@@ -152,6 +153,8 @@ extractGitConfig configsource r = GitConfig
 		getmaybebool (annex "resolvemerge")
 	, annexSyncContent = configurable False $ 
 		getmaybebool (annex "synccontent")
+	, annexSyncOnlyAnnex = configurable False $ 
+		getmaybebool (annex "synconlyannex")
 	, annexDebug = getbool (annex "debug") False
 	, annexWebOptions = getwords (annex "web-options")
 	, annexYoutubeDlOptions = getwords (annex "youtube-dl-options")
@@ -232,6 +235,7 @@ mergeGitConfig :: GitConfig -> GitConfig -> GitConfig
 mergeGitConfig gitconfig repoglobals = gitconfig
 	{ annexAutoCommit = merge annexAutoCommit
 	, annexSyncContent = merge annexSyncContent
+	, annexSyncOnlyAnnex = merge annexSyncOnlyAnnex
 	, annexResolveMerge = merge annexResolveMerge
 	, annexLargeFiles = merge annexLargeFiles
 	, annexDotFiles = merge annexDotFiles

Types/ProposedAccepted.hs

@@ -0,0 +1,38 @@
+{- proposed and accepted values
+ -
+ - Copyright 2020 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Types.ProposedAccepted where
+
+import Test.QuickCheck
+
+-- | A value that may be proposed, or accepted.
+--
+-- When parsing/validating the value, may want to error out on invalid
+-- input. But if a previous version of git-annex accepted an invalid value,
+-- it's too late to error out, and instead the bad value may be ignored.
+data ProposedAccepted t = Proposed t | Accepted t
+	deriving (Show)
+
+fromProposedAccepted :: ProposedAccepted t -> t
+fromProposedAccepted (Proposed t) = t
+fromProposedAccepted (Accepted t) = t
+
+-- | Whether a value is proposed or accepted does not matter when checking
+-- equality.
+instance Eq t => Eq (ProposedAccepted t) where
+	a == b = fromProposedAccepted a == fromProposedAccepted b
+
+-- | Order by the contained value, not by whether it's proposed or
+-- accepted.
+instance Ord t => Ord (ProposedAccepted t) where
+	compare a b = compare (fromProposedAccepted a) (fromProposedAccepted b)
+
+instance Arbitrary t => Arbitrary (ProposedAccepted t) where
+	arbitrary = oneof
+		[ Proposed <$> arbitrary
+		, Accepted <$> arbitrary
+		]

Types/Remote.hs

@@ -2,7 +2,7 @@
  -
  - 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.
  -}
@@ -10,8 +10,7 @@
 {-# LANGUAGE RankNTypes #-}
 
 module Types.Remote
-	( RemoteConfigField
-	, RemoteConfig
+	( module Types.RemoteConfig
 	, RemoteTypeA(..)
 	, RemoteA(..)
 	, RemoteStateHandle
@@ -28,7 +27,6 @@ module Types.Remote
 	)
 	where
 
-import qualified Data.Map as M
 import Data.Ord
 
 import qualified Git
@@ -42,6 +40,7 @@ import Types.UrlContents
 import Types.NumCopies
 import Types.Export
 import Types.Import
+import Types.RemoteConfig
 import Config.Cost
 import Utility.Metered
 import Git.Types (RemoteName)
@@ -49,10 +48,6 @@ import Utility.SafeCommand
 import Utility.Url
 import Utility.DataUnits
 
-type RemoteConfigField = String
-
-type RemoteConfig = M.Map RemoteConfigField String
-
 data SetupStage = Init | Enable RemoteConfig
 
 {- There are different types of remotes. -}
@@ -63,13 +58,15 @@ data RemoteTypeA a = RemoteType
 	-- The Bool is True if automatic initialization of remotes is desired
 	, enumerate :: Bool -> a [Git.Repo]
 	-- generates a remote of this type
-	, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
+	, generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
+	-- parse configs of remotes of this type
+	, configParser :: RemoteConfig -> a RemoteConfigParser
 	-- initializes or enables a remote
 	, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
 	-- 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
-	, importSupported :: RemoteConfig -> RemoteGitConfig -> a Bool
+	, importSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool
 	}
 
 instance Eq (RemoteTypeA a) where
@@ -124,7 +121,7 @@ data RemoteA a = Remote
 	-- Runs an action to repair the remote's git repository.
 	, repairRepo :: Maybe (a Bool -> a (IO Bool))
 	-- a Remote has a persistent configuration store
-	, config :: RemoteConfig
+	, config :: ParsedRemoteConfig
 	-- Get the git repo for the Remote.
 	, getRepo :: a Git.Repo
 	-- a Remote's configuration from git

Types/RemoteConfig.hs

@@ -0,0 +1,69 @@
+{- 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 qualified Data.Set as S
+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
+
+{- 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.
+ -}
+data RemoteConfigFieldParser = RemoteConfigFieldParser
+	{ parserForField :: RemoteConfigField
+	, valueParser :: Maybe (ProposedAccepted String) -> RemoteConfig -> Either String (Maybe RemoteConfigValue)
+	, fieldDesc :: FieldDesc
+	, valueDesc :: Maybe ValueDesc
+	}
+
+data FieldDesc
+	= FieldDesc String
+	| HiddenField
+
+newtype ValueDesc = ValueDesc String
+
+data RemoteConfigParser = RemoteConfigParser
+	{ remoteConfigFieldParsers :: [RemoteConfigFieldParser]
+	, remoteConfigRestPassthrough :: Maybe (RemoteConfigField -> Bool, [(String, FieldDesc)])
+	}
+
+mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> RemoteConfig -> m RemoteConfigParser
+mkRemoteConfigParser l _ = pure (RemoteConfigParser l Nothing)
+
+addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser
+addRemoteConfigParser l rpc = rpc
+	{ remoteConfigFieldParsers = 
+		remoteConfigFieldParsers rpc ++ filter isnew l
+	}
+  where
+	s = S.fromList (map parserForField (remoteConfigFieldParsers rpc))
+	isnew p = not (S.member (parserForField p) s)

Types/RemoteState.hs

@@ -9,7 +9,7 @@ module Types.RemoteState where
 
 import Types.UUID
 
-{- When per-remote state, its UUID is used to identify it.
+{- When there is per-remote state, remotes are identified by UUID.
  -
  - However, sameas remotes mean that two different Remote implementations
  - can be used for the same underlying data store. To avoid them using

Types/StandardGroups.hs

@@ -11,9 +11,10 @@ module Types.StandardGroups where
 
 import Types.Remote (RemoteConfig)
 import Types.Group
+import Types.ProposedAccepted
+import Annex.SpecialRemote.Config (preferreddirField)
 
 import qualified Data.Map as M
-import Data.Maybe
 
 type PreferredContentExpression = String
 
@@ -71,7 +72,8 @@ associatedDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath
 associatedDirectory _ SmallArchiveGroup = Just "archive"
 associatedDirectory _ FullArchiveGroup = Just "archive"
 associatedDirectory (Just c) PublicGroup = Just $
-	fromMaybe "public" $ M.lookup "preferreddir" c
+	maybe "public" fromProposedAccepted $
+		M.lookup preferreddirField c
 associatedDirectory Nothing PublicGroup = Just "public"
 associatedDirectory _ _ = Nothing