1{- git-annex configuration
2 -
3 - Copyright 2012-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
9{-# LANGUAGE OverloadedStrings #-}
10
11module Types.GitConfig (
12	GlobalConfigurable(..),
13	ConfigSource(..),
14	GitConfig(..),
15	extractGitConfig,
16	mergeGitConfig,
17	globalConfigs,
18	RemoteGitConfig(..),
19	extractRemoteGitConfig,
20	dummyRemoteGitConfig,
21	annexConfig,
22	RemoteNameable(..),
23	remoteAnnexConfig,
24	remoteConfig,
25) where
26
27import Common
28import qualified Git
29import qualified Git.Config
30import qualified Git.Construct
31import Git.Types
32import Git.ConfigTypes
33import Git.Remote (isRemoteKey, remoteKeyToRemoteName)
34import Git.Branch (CommitMode(..))
35import Utility.DataUnits
36import Config.Cost
37import Types.UUID
38import Types.Distribution
39import Types.Availability
40import Types.Concurrency
41import Types.NumCopies
42import Types.Difference
43import Types.RefSpec
44import Types.RepoVersion
45import Types.StallDetection
46import Config.DynamicConfig
47import Utility.HumanTime
48import Utility.Gpg (GpgCmd, mkGpgCmd)
49import Utility.ThreadScheduler (Seconds(..))
50import Utility.Url (Scheme, mkScheme)
51
52import Control.Concurrent.STM
53import qualified Data.Set as S
54import qualified Data.Map as M
55import qualified Data.ByteString as B
56
57-- | A configurable value, that may not be fully determined yet because
58-- the global git config has not yet been loaded.
59data GlobalConfigurable a
60	= HasGitConfig a
61	-- ^ The git config has a value.
62	| HasGlobalConfig a
63	-- ^ The global config has a value (and the git config does not).
64	| DefaultConfig a
65	-- ^ A default value is known, but not all config sources
66	-- have been read yet.
67	deriving (Show)
68
69data ConfigSource = FromGitConfig | FromGlobalConfig
70
71{- Main git-annex settings. Each setting corresponds to a git-config key
72 - such as annex.foo -}
73data GitConfig = GitConfig
74	{ annexVersion :: Maybe RepoVersion
75	, annexUUID :: UUID
76	, annexNumCopies :: Maybe NumCopies
77	, annexDiskReserve :: Integer
78	, annexDirect :: Bool
79	, annexBackend :: Maybe String
80	, annexQueueSize :: Maybe Int
81	, annexBloomCapacity :: Maybe Int
82	, annexBloomAccuracy :: Maybe Int
83	, annexSshCaching :: Maybe Bool
84	, annexAlwaysCommit :: Bool
85	, annexCommitMessage :: Maybe String
86	, annexMergeAnnexBranches :: Bool
87	, annexDelayAdd :: Maybe Int
88	, annexHttpHeaders :: [String]
89	, annexHttpHeadersCommand :: Maybe String
90	, annexAutoCommit :: GlobalConfigurable Bool
91	, annexResolveMerge :: GlobalConfigurable Bool
92	, annexSyncContent :: GlobalConfigurable Bool
93	, annexSyncOnlyAnnex :: GlobalConfigurable Bool
94	, annexDebug :: Bool
95	, annexDebugFilter :: Maybe String
96	, annexWebOptions :: [String]
97	, annexYoutubeDlOptions :: [String]
98	, annexYoutubeDlCommand :: Maybe String
99	, annexAriaTorrentOptions :: [String]
100	, annexCrippledFileSystem :: Bool
101	, annexLargeFiles :: GlobalConfigurable (Maybe String)
102	, annexDotFiles :: GlobalConfigurable Bool
103	, annexGitAddToAnnex :: Bool
104	, annexAddSmallFiles :: Bool
105	, annexFsckNudge :: Bool
106	, annexAutoUpgrade :: AutoUpgrade
107	, annexExpireUnused :: Maybe (Maybe Duration)
108	, annexFreezeContentCommand :: Maybe String
109	, annexThawContentCommand :: Maybe String
110	, annexSecureEraseCommand :: Maybe String
111	, annexGenMetaData :: Bool
112	, annexListen :: Maybe String
113	, annexStartupScan :: Bool
114	, annexHardLink :: Bool
115	, annexThin :: Bool
116	, annexDifferences :: Differences
117	, annexUsedRefSpec :: Maybe RefSpec
118	, annexVerify :: Bool
119	, annexPidLock :: Bool
120	, annexPidLockTimeout :: Seconds
121	, annexAddUnlocked :: GlobalConfigurable (Maybe String)
122	, annexSecureHashesOnly :: Bool
123	, annexRetry :: Maybe Integer
124	, annexForwardRetry :: Maybe Integer
125	, annexRetryDelay :: Maybe Seconds
126	, annexStallDetection :: Maybe StallDetection
127	, annexAllowedUrlSchemes :: S.Set Scheme
128	, annexAllowedIPAddresses :: String
129	, annexAllowUnverifiedDownloads :: Bool
130	, annexMaxExtensionLength :: Maybe Int
131	, annexJobs :: Concurrency
132	, annexCacheCreds :: Bool
133	, annexAutoUpgradeRepository :: Bool
134	, annexCommitMode :: CommitMode
135	, annexSkipUnknown :: Bool
136	, annexAdjustedBranchRefresh :: Integer
137	, annexSupportUnlocked :: Bool
138	, coreSymlinks :: Bool
139	, coreSharedRepository :: SharedRepository
140	, receiveDenyCurrentBranch :: DenyCurrentBranch
141	, gcryptId :: Maybe String
142	, gpgCmd :: GpgCmd
143	, mergeDirectoryRenames :: Maybe String
144	, annexPrivateRepos :: S.Set UUID
145	, annexAdviceNoSshCaching :: Bool
146	}
147
148extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig
149extractGitConfig configsource r = GitConfig
150	{ annexVersion = RepoVersion <$> getmayberead (annexConfig "version")
151	, annexUUID = hereuuid
152	, annexNumCopies = NumCopies <$> getmayberead (annexConfig "numcopies")
153	, annexDiskReserve = fromMaybe onemegabyte $
154		readSize dataUnits =<< getmaybe (annexConfig "diskreserve")
155	, annexDirect = getbool (annexConfig "direct") False
156	, annexBackend = maybe
157		-- annex.backends is the old name of the option, still used
158		-- when annex.backend is not set.
159		(headMaybe $ getwords (annexConfig "backends"))
160		Just
161		(getmaybe (annexConfig "backend"))
162	, annexQueueSize = getmayberead (annexConfig "queuesize")
163	, annexBloomCapacity = getmayberead (annexConfig "bloomcapacity")
164	, annexBloomAccuracy = getmayberead (annexConfig "bloomaccuracy")
165	, annexSshCaching = getmaybebool (annexConfig "sshcaching")
166	, annexAlwaysCommit = getbool (annexConfig "alwayscommit") True
167	, annexCommitMessage = getmaybe (annexConfig "commitmessage")
168	, annexMergeAnnexBranches = getbool (annexConfig "merge-annex-branches") True
169	, annexDelayAdd = getmayberead (annexConfig "delayadd")
170	, annexHttpHeaders = getlist (annexConfig "http-headers")
171	, annexHttpHeadersCommand = getmaybe (annexConfig "http-headers-command")
172	, annexAutoCommit = configurable True $
173		getmaybebool (annexConfig "autocommit")
174	, annexResolveMerge = configurable True $
175		getmaybebool (annexConfig "resolvemerge")
176	, annexSyncContent = configurable False $
177		getmaybebool (annexConfig "synccontent")
178	, annexSyncOnlyAnnex = configurable False $
179		getmaybebool (annexConfig "synconlyannex")
180	, annexDebug = getbool (annexConfig "debug") False
181	, annexDebugFilter = getmaybe (annexConfig "debugfilter")
182	, annexWebOptions = getwords (annexConfig "web-options")
183	, annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options")
184	, annexYoutubeDlCommand = getmaybe (annexConfig "youtube-dl-command")
185	, annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options")
186	, annexCrippledFileSystem = getbool (annexConfig "crippledfilesystem") False
187	, annexLargeFiles = configurable Nothing $
188		fmap Just $ getmaybe (annexConfig "largefiles")
189	, annexDotFiles = configurable False $
190		getmaybebool (annexConfig "dotfiles")
191	, annexGitAddToAnnex = getbool (annexConfig "gitaddtoannex") True
192	, annexAddSmallFiles = getbool (annexConfig "addsmallfiles") True
193	, annexFsckNudge = getbool (annexConfig "fscknudge") True
194	, annexAutoUpgrade = toAutoUpgrade $
195		getmaybe (annexConfig "autoupgrade")
196	, annexExpireUnused = either (const Nothing) Just . parseDuration
197		<$> getmaybe (annexConfig "expireunused")
198	, annexFreezeContentCommand = getmaybe (annexConfig "freezecontent-command")
199	, annexThawContentCommand = getmaybe (annexConfig "thawcontent-command")
200	, annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command")
201	, annexGenMetaData = getbool (annexConfig "genmetadata") False
202	, annexListen = getmaybe (annexConfig "listen")
203	, annexStartupScan = getbool (annexConfig "startupscan") True
204	, annexHardLink = getbool (annexConfig "hardlink") False
205	, annexThin = getbool (annexConfig "thin") False
206	, annexDifferences = getDifferences r
207	, annexUsedRefSpec = either (const Nothing) Just . parseRefSpec
208		=<< getmaybe (annexConfig "used-refspec")
209	, annexVerify = getbool (annexConfig "verify") True
210	, annexPidLock = getbool (annexConfig "pidlock") False
211	, annexPidLockTimeout = Seconds $ fromMaybe 300 $
212		getmayberead (annexConfig "pidlocktimeout")
213	, annexAddUnlocked = configurable Nothing $
214		fmap Just $ getmaybe (annexConfig "addunlocked")
215	, annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False
216	, annexRetry = getmayberead (annexConfig "retry")
217	, annexForwardRetry = getmayberead (annexConfig "forward-retry")
218	, annexRetryDelay = Seconds
219		<$> getmayberead (annexConfig "retrydelay")
220	, annexStallDetection =
221		either (const Nothing) id . parseStallDetection
222			=<< getmaybe (annexConfig "stalldetection")
223	, annexAllowedUrlSchemes = S.fromList $ map mkScheme $
224		maybe ["http", "https", "ftp"] words $
225			getmaybe (annexConfig "security.allowed-url-schemes")
226	, annexAllowedIPAddresses = fromMaybe "" $
227		getmaybe (annexConfig "security.allowed-ip-addresses")
228			<|>
229		getmaybe (annexConfig "security.allowed-http-addresses") -- old name
230	, annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $
231		getmaybe (annexConfig "security.allow-unverified-downloads")
232	, annexMaxExtensionLength = getmayberead (annexConfig "maxextensionlength")
233	, annexJobs = fromMaybe NonConcurrent $
234		parseConcurrency =<< getmaybe (annexConfig "jobs")
235	, annexCacheCreds = getbool (annexConfig "cachecreds") True
236	, annexAutoUpgradeRepository = getbool (annexConfig "autoupgraderepository") True
237	, annexCommitMode = if getbool (annexConfig "allowsign") False
238		then ManualCommit
239		else AutomaticCommit
240	, annexSkipUnknown = getbool (annexConfig "skipunknown") True
241	, annexAdjustedBranchRefresh = fromMaybe
242		-- parse as bool if it's not a number
243		(if getbool "adjustedbranchrefresh" False then 1 else 0)
244		(getmayberead (annexConfig "adjustedbranchrefresh"))
245	, annexSupportUnlocked = getbool (annexConfig "supportunlocked") True
246	, coreSymlinks = getbool "core.symlinks" True
247	, coreSharedRepository = getSharedRepository r
248	, receiveDenyCurrentBranch = getDenyCurrentBranch r
249	, gcryptId = getmaybe "core.gcrypt-id"
250	, gpgCmd = mkGpgCmd (getmaybe "gpg.program")
251	, mergeDirectoryRenames = getmaybe "directoryrenames"
252	, annexPrivateRepos = S.fromList $ concat
253		[ if getbool (annexConfig "private") False
254			then [hereuuid]
255			else []
256		, let get (k, v)
257			| Git.Config.isTrueFalse' v /= Just True = Nothing
258			| isRemoteKey (remoteAnnexConfigEnd "private") k = do
259				remotename <- remoteKeyToRemoteName k
260				toUUID <$> Git.Config.getMaybe
261					(remoteAnnexConfig remotename "uuid") r
262			| otherwise = Nothing
263		  in mapMaybe get (M.toList (Git.config r))
264		]
265	, annexAdviceNoSshCaching = getbool (annexConfig "adviceNoSshCaching") True
266	}
267  where
268	getbool k d = fromMaybe d $ getmaybebool k
269	getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k
270	getmayberead k = readish =<< getmaybe k
271	getmaybe = fmap fromConfigValue . getmaybe'
272	getmaybe' k = Git.Config.getMaybe k r
273	getlist k = map fromConfigValue $ Git.Config.getList k r
274	getwords k = fromMaybe [] $ words <$> getmaybe k
275
276	configurable d Nothing = DefaultConfig d
277	configurable _ (Just v) = case configsource of
278		FromGitConfig -> HasGitConfig v
279		FromGlobalConfig -> HasGlobalConfig v
280
281	onemegabyte = 1000000
282
283	hereuuid = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid")
284
285{- Merge a GitConfig that comes from git-config with one containing
286 - repository-global defaults. -}
287mergeGitConfig :: GitConfig -> GitConfig -> GitConfig
288mergeGitConfig gitconfig repoglobals = gitconfig
289	{ annexAutoCommit = merge annexAutoCommit
290	, annexSyncContent = merge annexSyncContent
291	, annexSyncOnlyAnnex = merge annexSyncOnlyAnnex
292	, annexResolveMerge = merge annexResolveMerge
293	, annexLargeFiles = merge annexLargeFiles
294	, annexDotFiles = merge annexDotFiles
295	, annexAddUnlocked = merge annexAddUnlocked
296	}
297  where
298	merge f = case f gitconfig of
299		HasGitConfig v -> HasGitConfig v
300		DefaultConfig d -> case f repoglobals of
301			HasGlobalConfig v -> HasGlobalConfig v
302			_ -> HasGitConfig d
303		HasGlobalConfig v -> HasGlobalConfig v
304
305{- Configs that can be set repository-global. -}
306globalConfigs :: [ConfigKey]
307globalConfigs =
308	[ annexConfig "largefiles"
309	, annexConfig "dotfiles"
310	, annexConfig "addunlocked"
311	, annexConfig "autocommit"
312	, annexConfig "resolvemerge"
313	, annexConfig "synccontent"
314	, annexConfig "synconlyannex"
315	, annexConfig "securehashesonly"
316	]
317
318{- Per-remote git-annex settings. Each setting corresponds to a git-config
319 - key such as <remote>.annex-foo, or if that is not set, a default from
320 - annex.foo.
321 -
322 - Note that this is from the perspective of the local repository,
323 - it is not influenced in any way by the contents of the remote
324 - repository's git config.
325 -}
326data RemoteGitConfig = RemoteGitConfig
327	{ remoteAnnexCost :: DynamicConfig (Maybe Cost)
328	, remoteAnnexIgnore :: DynamicConfig Bool
329	, remoteAnnexSync :: DynamicConfig Bool
330	, remoteAnnexPull :: Bool
331	, remoteAnnexPush :: Bool
332	, remoteAnnexReadOnly :: Bool
333	, remoteAnnexVerify :: Bool
334	, remoteAnnexCheckUUID :: Bool
335	, remoteAnnexTrackingBranch :: Maybe Git.Ref
336	, remoteAnnexTrustLevel :: Maybe String
337	, remoteAnnexStartCommand :: Maybe String
338	, remoteAnnexStopCommand :: Maybe String
339	, remoteAnnexAvailability :: Maybe Availability
340	, remoteAnnexSpeculatePresent :: Bool
341	, remoteAnnexBare :: Maybe Bool
342	, remoteAnnexRetry :: Maybe Integer
343	, remoteAnnexForwardRetry :: Maybe Integer
344	, remoteAnnexRetryDelay :: Maybe Seconds
345	, remoteAnnexStallDetection :: Maybe StallDetection
346	, remoteAnnexAllowUnverifiedDownloads :: Bool
347	, remoteAnnexConfigUUID :: Maybe UUID
348
349	{- These settings are specific to particular types of remotes
350	 - including special remotes. -}
351	, remoteAnnexShell :: Maybe String
352	, remoteAnnexSshOptions :: [String]
353	, remoteAnnexRsyncOptions :: [String]
354	, remoteAnnexRsyncUploadOptions :: [String]
355	, remoteAnnexRsyncDownloadOptions :: [String]
356	, remoteAnnexRsyncTransport :: [String]
357	, remoteAnnexGnupgOptions :: [String]
358	, remoteAnnexGnupgDecryptOptions :: [String]
359	, remoteAnnexRsyncUrl :: Maybe String
360	, remoteAnnexBupRepo :: Maybe String
361	, remoteAnnexBorgRepo :: Maybe String
362	, remoteAnnexTahoe :: Maybe FilePath
363	, remoteAnnexBupSplitOptions :: [String]
364	, remoteAnnexDirectory :: Maybe FilePath
365	, remoteAnnexAndroidDirectory :: Maybe FilePath
366	, remoteAnnexAndroidSerial :: Maybe String
367	, remoteAnnexGCrypt :: Maybe String
368	, remoteAnnexGitLFS :: Bool
369	, remoteAnnexDdarRepo :: Maybe String
370	, remoteAnnexHookType :: Maybe String
371	, remoteAnnexExternalType :: Maybe String
372	}
373
374{- The Git.Repo is the local repository, which has the remote with the
375 - given RemoteName. -}
376extractRemoteGitConfig :: Git.Repo -> RemoteName -> STM RemoteGitConfig
377extractRemoteGitConfig r remotename = do
378	annexcost <- mkDynamicConfig readCommandRunner
379		(notempty $ getmaybe "cost-command")
380		(getmayberead "cost")
381	annexignore <- mkDynamicConfig unsuccessfullCommandRunner
382		(notempty $ getmaybe "ignore-command")
383		(getbool "ignore" False)
384	annexsync <- mkDynamicConfig successfullCommandRunner
385		(notempty $ getmaybe "sync-command")
386		(getbool "sync" True)
387	return $ RemoteGitConfig
388		{ remoteAnnexCost = annexcost
389		, remoteAnnexIgnore = annexignore
390		, remoteAnnexSync = annexsync
391		, remoteAnnexPull = getbool "pull" True
392		, remoteAnnexPush = getbool "push" True
393		, remoteAnnexReadOnly = getbool "readonly" False
394		, remoteAnnexCheckUUID = getbool "checkuuid" True
395		, remoteAnnexVerify = getbool "verify" True
396		, remoteAnnexTrackingBranch = Git.Ref . encodeBS <$>
397			( notempty (getmaybe "tracking-branch")
398			<|> notempty (getmaybe "export-tracking") -- old name
399			)
400		, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel"
401		, remoteAnnexStartCommand = notempty $ getmaybe "start-command"
402		, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"
403		, remoteAnnexAvailability = getmayberead "availability"
404		, remoteAnnexSpeculatePresent = getbool "speculate-present" False
405		, remoteAnnexBare = getmaybebool "bare"
406		, remoteAnnexRetry = getmayberead "retry"
407		, remoteAnnexForwardRetry = getmayberead "forward-retry"
408		, remoteAnnexRetryDelay = Seconds
409			<$> getmayberead "retrydelay"
410		, remoteAnnexStallDetection =
411			either (const Nothing) id . parseStallDetection
412				=<< getmaybe "stalldetection"
413		, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $
414			getmaybe ("security-allow-unverified-downloads")
415		, remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid"
416		, remoteAnnexShell = getmaybe "shell"
417		, remoteAnnexSshOptions = getoptions "ssh-options"
418		, remoteAnnexRsyncOptions = getoptions "rsync-options"
419		, remoteAnnexRsyncDownloadOptions = getoptions "rsync-download-options"
420		, remoteAnnexRsyncUploadOptions = getoptions "rsync-upload-options"
421		, remoteAnnexRsyncTransport = getoptions "rsync-transport"
422		, remoteAnnexGnupgOptions = getoptions "gnupg-options"
423		, remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options"
424		, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl"
425		, remoteAnnexBupRepo = getmaybe "buprepo"
426		, remoteAnnexBorgRepo = getmaybe "borgrepo"
427		, remoteAnnexTahoe = getmaybe "tahoe"
428		, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
429		, remoteAnnexDirectory = notempty $ getmaybe "directory"
430		, remoteAnnexAndroidDirectory = notempty $ getmaybe "androiddirectory"
431		, remoteAnnexAndroidSerial = notempty $ getmaybe "androidserial"
432		, remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"
433		, remoteAnnexGitLFS = getbool "git-lfs" False
434		, remoteAnnexDdarRepo = getmaybe "ddarrepo"
435		, remoteAnnexHookType = notempty $ getmaybe "hooktype"
436		, remoteAnnexExternalType = notempty $ getmaybe "externaltype"
437		}
438  where
439	getbool k d = fromMaybe d $ getmaybebool k
440	getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k
441	getmayberead k = readish =<< getmaybe k
442	getmaybe = fmap fromConfigValue . getmaybe'
443	getmaybe' k = mplus (Git.Config.getMaybe (annexConfig k) r)
444		(Git.Config.getMaybe (remoteAnnexConfig remotename k) r)
445	getoptions k = fromMaybe [] $ words <$> getmaybe k
446
447notempty :: Maybe String -> Maybe String
448notempty Nothing = Nothing
449notempty (Just "") = Nothing
450notempty (Just s) = Just s
451
452dummyRemoteGitConfig :: IO RemoteGitConfig
453dummyRemoteGitConfig = atomically $
454	extractRemoteGitConfig Git.Construct.fromUnknown "dummy"
455
456type UnqualifiedConfigKey = B.ByteString
457
458{- A global annex setting in git config. -}
459annexConfig :: UnqualifiedConfigKey -> ConfigKey
460annexConfig key = ConfigKey ("annex." <> key)
461
462class RemoteNameable r where
463	getRemoteName :: r -> RemoteName
464
465instance RemoteNameable Git.Repo where
466	getRemoteName r = fromMaybe "" (Git.remoteName r)
467
468instance RemoteNameable RemoteName where
469	 getRemoteName = id
470
471{- A per-remote annex setting in git config. -}
472remoteAnnexConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
473remoteAnnexConfig r = remoteConfig r . remoteAnnexConfigEnd
474
475remoteAnnexConfigEnd :: UnqualifiedConfigKey -> UnqualifiedConfigKey
476remoteAnnexConfigEnd key = "annex-" <> key
477
478{- A per-remote setting in git config. -}
479remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
480remoteConfig r key = ConfigKey $
481	"remote." <> encodeBS (getRemoteName r) <> "." <> key
482