1{- git-annex special remote configuration
2 -
3 - Copyright 2019-2020 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
9{-# OPTIONS_GHC -fno-warn-orphans #-}
10
11module Annex.SpecialRemote.Config where
12
13import Common
14import Types.Remote (configParser)
15import Types
16import Types.UUID
17import Types.ProposedAccepted
18import Types.RemoteConfig
19import Types.GitConfig
20
21import qualified Data.Map as M
22import qualified Data.Set as S
23import Data.Typeable
24import GHC.Stack
25
26newtype Sameas t = Sameas t
27	deriving (Show)
28
29newtype ConfigFrom t = ConfigFrom t
30	deriving (Show)
31
32{- The name of a configured remote is stored in its config using this key. -}
33nameField :: RemoteConfigField
34nameField = Accepted "name"
35
36{- The name of a sameas remote is stored using this key instead.
37 - This prevents old versions of git-annex getting confused. -}
38sameasNameField :: RemoteConfigField
39sameasNameField = Accepted "sameas-name"
40
41lookupName :: RemoteConfig -> Maybe String
42lookupName c = fmap fromProposedAccepted $
43	M.lookup nameField c <|> M.lookup sameasNameField c
44
45instance RemoteNameable RemoteConfig where
46	getRemoteName c = fromMaybe "" (lookupName c)
47
48{- The uuid that a sameas remote is the same as is stored in this key. -}
49sameasUUIDField :: RemoteConfigField
50sameasUUIDField = Accepted "sameas-uuid"
51
52{- The type of a remote is stored in its config using this key. -}
53typeField :: RemoteConfigField
54typeField = Accepted "type"
55
56autoEnableField :: RemoteConfigField
57autoEnableField = Accepted "autoenable"
58
59encryptionField :: RemoteConfigField
60encryptionField = Accepted "encryption"
61
62macField :: RemoteConfigField
63macField = Accepted "mac"
64
65cipherField :: RemoteConfigField
66cipherField = Accepted "cipher"
67
68cipherkeysField :: RemoteConfigField
69cipherkeysField = Accepted "cipherkeys"
70
71pubkeysField :: RemoteConfigField
72pubkeysField = Accepted "pubkeys"
73
74chunkField :: RemoteConfigField
75chunkField = Accepted "chunk"
76
77chunksizeField :: RemoteConfigField
78chunksizeField = Accepted "chunksize"
79
80embedCredsField :: RemoteConfigField
81embedCredsField = Accepted "embedcreds"
82
83preferreddirField :: RemoteConfigField
84preferreddirField = Accepted "preferreddir"
85
86exportTreeField :: RemoteConfigField
87exportTreeField = Accepted "exporttree"
88
89importTreeField :: RemoteConfigField
90importTreeField = Accepted "importtree"
91
92exportTree :: ParsedRemoteConfig -> Bool
93exportTree = fromMaybe False . getRemoteConfigValue exportTreeField
94
95importTree :: ParsedRemoteConfig -> Bool
96importTree = fromMaybe False . getRemoteConfigValue importTreeField
97
98{- Parsers for fields that are common to all special remotes. -}
99commonFieldParsers :: [RemoteConfigFieldParser]
100commonFieldParsers =
101	[ optionalStringParser nameField
102		(FieldDesc "name for the special remote")
103	, optionalStringParser sameasNameField HiddenField
104	, optionalStringParser sameasUUIDField HiddenField
105	, optionalStringParser typeField
106		(FieldDesc "type of special remote")
107	, trueFalseParser autoEnableField (Just False)
108		(FieldDesc "automatically enable special remote")
109	, yesNoParser exportTreeField (Just False)
110		(FieldDesc "export trees of files to this remote")
111	, yesNoParser importTreeField (Just False)
112		(FieldDesc "import trees of files from this remote")
113	, optionalStringParser preferreddirField
114		(FieldDesc "directory whose content is preferred")
115	]
116
117{- A remote with sameas-uuid set will inherit these values from the config
118 - of that uuid. These values cannot be overridden in the remote's config. -}
119sameasInherits :: S.Set RemoteConfigField
120sameasInherits = S.fromList
121	-- encryption configuration is necessarily the same for two
122	-- remotes that access the same data store
123	[ encryptionField
124	, macField
125	, cipherField
126	, cipherkeysField
127	, pubkeysField
128	-- legacy chunking was either enabled or not, so has to be the same
129	-- across configs for remotes that access the same data
130	-- (new-style chunking does not have that limitation)
131	, chunksizeField
132	]
133
134{- Each RemoteConfig that has a sameas-uuid inherits some fields
135 - from it. Such fields can only be set by inheritance; the RemoteConfig
136 - cannot provide values from them. -}
137addSameasInherited :: M.Map UUID RemoteConfig -> RemoteConfig -> RemoteConfig
138addSameasInherited m c = case findSameasUUID c of
139	Nothing -> c
140	Just (Sameas sameasuuid) -> case M.lookup sameasuuid m of
141		Nothing -> c
142		Just parentc ->
143			M.withoutKeys c sameasInherits
144				`M.union`
145			M.restrictKeys parentc sameasInherits
146
147findSameasUUID :: RemoteConfig -> Maybe (Sameas UUID)
148findSameasUUID c = Sameas . toUUID . fromProposedAccepted
149	<$> M.lookup sameasUUIDField c
150
151{- Remove any fields inherited from a sameas-uuid. When storing a
152 - RemoteConfig, those fields don't get stored, since they were already
153 - inherited. -}
154removeSameasInherited :: RemoteConfig -> RemoteConfig
155removeSameasInherited c = case M.lookup sameasUUIDField c of
156	Nothing -> c
157	Just _ -> M.withoutKeys c sameasInherits
158
159{- Finds remote uuids with matching RemoteConfig. -}
160findByRemoteConfig :: (RemoteConfig -> Bool) -> M.Map UUID RemoteConfig -> [(UUID, RemoteConfig, Maybe (ConfigFrom UUID))]
161findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toList
162  where
163	sameasuuid (u, c) = case M.lookup sameasUUIDField c of
164		Nothing -> (u, c, Nothing)
165		Just u' -> (toUUID (fromProposedAccepted u'), c, Just (ConfigFrom u))
166
167{- Extracts a value from ParsedRemoteConfig. -}
168getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v
169getRemoteConfigValue f (ParsedRemoteConfig m _) = case M.lookup f m of
170	Just (RemoteConfigValue v) -> case cast v of
171		Just v' -> Just v'
172		Nothing -> error $ unwords
173			[ "getRemoteConfigValue"
174			, fromProposedAccepted f
175			, "found value of unexpected type"
176			, show (typeOf v) ++ "."
177			, "This is a bug in git-annex!"
178			]
179	Nothing -> Nothing
180
181{- Gets all fields that remoteConfigRestPassthrough matched. -}
182getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String
183getRemoteConfigPassedThrough (ParsedRemoteConfig m _) =
184	flip M.mapMaybe m $ \(RemoteConfigValue v) ->
185		case cast v of
186			Just (PassedThrough s) -> Just s
187			Nothing -> Nothing
188
189newtype PassedThrough = PassedThrough String
190
191parsedRemoteConfig :: RemoteType -> RemoteConfig -> Annex ParsedRemoteConfig
192parsedRemoteConfig t c = either (const emptycfg) id . parseRemoteConfig c
193	<$> configParser t c
194  where
195	emptycfg = ParsedRemoteConfig mempty c
196
197parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig
198parseRemoteConfig c rpc =
199	go [] c (remoteConfigFieldParsers rpc ++ commonFieldParsers)
200  where
201	go l c' [] =
202		let (passover, leftovers) = partition
203			(maybe (const False) fst (remoteConfigRestPassthrough rpc) . fst)
204			(M.toList c')
205		    leftovers' = filter (notaccepted . fst) leftovers
206		in if not (null leftovers')
207			then Left $ "Unexpected parameters: " ++
208				unwords (map (fromProposedAccepted . fst) leftovers')
209			else
210				let m = M.fromList $
211					l ++ map (uncurry passthrough) passover
212				in Right (ParsedRemoteConfig m c)
213	go l c' (p:rest) = do
214		let f = parserForField p
215		(valueParser p) (M.lookup f c) c >>= \case
216			Just v -> go ((f,v):l) (M.delete f c') rest
217			Nothing -> go l (M.delete f c') rest
218
219	passthrough f v = (f, RemoteConfigValue (PassedThrough (fromProposedAccepted v)))
220
221	notaccepted (Proposed _) = True
222	notaccepted (Accepted _) = False
223
224optionalStringParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser
225optionalStringParser f fielddesc = RemoteConfigFieldParser
226	{ parserForField = f
227	, valueParser = p
228	, fieldDesc = fielddesc
229	, valueDesc = Nothing
230	}
231  where
232	p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v)))
233	p Nothing _c = Right Nothing
234
235yesNoParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser
236yesNoParser f mdef fd = genParser yesno f mdef fd
237	(Just (ValueDesc "yes or no"))
238  where
239	yesno "yes" = Just True
240	yesno "no" = Just False
241	yesno _ = Nothing
242
243trueFalseParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser
244trueFalseParser f mdef fd = genParser trueFalseParser' f mdef fd
245	(Just (ValueDesc "true or false"))
246
247-- Not using Git.Config.isTrueFalse because git supports
248-- a lot of other values for true and false in its configs,
249-- and this is not a git config and we want to avoid that mess.
250trueFalseParser' :: String -> Maybe Bool
251trueFalseParser' "true" = Just True
252trueFalseParser' "false" = Just False
253trueFalseParser' _ = Nothing
254
255genParser
256	:: Typeable t
257	=> (String -> Maybe t)
258	-> RemoteConfigField
259	-> Maybe t -- ^ default if not configured
260	-> FieldDesc
261	-> Maybe ValueDesc
262	-> RemoteConfigFieldParser
263genParser parse f mdef fielddesc valuedesc = RemoteConfigFieldParser
264	{ parserForField = f
265	, valueParser = p
266	, fieldDesc = fielddesc
267	, valueDesc = valuedesc
268	}
269  where
270	p Nothing _c = Right (fmap RemoteConfigValue mdef)
271	p (Just v) _c = case parse (fromProposedAccepted v) of
272		Just b -> Right (Just (RemoteConfigValue b))
273		Nothing -> case v of
274			Accepted _ -> Right (fmap RemoteConfigValue mdef)
275			Proposed _ -> Left $
276				"Bad value for " ++ fromProposedAccepted f ++
277				case valuedesc of
278					Just (ValueDesc vd) ->
279						" (expected " ++ vd ++ ")"
280					Nothing -> ""
281