1{- git-annex monad
2 -
3 - Copyright 2010-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-}
9
10module Annex (
11	Annex,
12	AnnexState(..),
13	AnnexRead(..),
14	new,
15	run,
16	eval,
17	makeRunner,
18	getRead,
19	getState,
20	changeState,
21	withState,
22	setFlag,
23	setField,
24	setOutput,
25	getFlag,
26	getField,
27	addCleanupAction,
28	gitRepo,
29	inRepo,
30	fromRepo,
31	calcRepo,
32	getGitConfig,
33	overrideGitConfig,
34	changeGitRepo,
35	adjustGitRepo,
36	addGitConfigOverride,
37	getGitConfigOverrides,
38	getRemoteGitConfig,
39	withCurrentState,
40	changeDirectory,
41	getGitRemotes,
42	incError,
43) where
44
45import Common
46import qualified Git
47import qualified Git.Config
48import qualified Git.Construct
49import Annex.Fixup
50import Git.HashObject
51import Git.CheckAttr
52import Git.CheckIgnore
53import qualified Git.Hook
54import qualified Git.Queue
55import Types.Key
56import Types.Backend
57import Types.GitConfig
58import qualified Types.Remote
59import Types.Crypto
60import Types.BranchState
61import Types.TrustLevel
62import Types.Group
63import Types.Messages
64import Types.Concurrency
65import Types.UUID
66import Types.FileMatcher
67import Types.NumCopies
68import Types.LockCache
69import Types.DesktopNotify
70import Types.CleanupActions
71import Types.AdjustedBranch
72import Types.WorkerPool
73import Types.IndexFiles
74import Types.CatFileHandles
75import Types.RemoteConfig
76import Types.TransferrerPool
77import Types.VectorClock
78import Annex.VectorClock.Utility
79import Annex.Debug.Utility
80import qualified Database.Keys.Handle as Keys
81import Utility.InodeCache
82import Utility.Url
83import Utility.ResourcePool
84import Utility.HumanTime
85
86import "mtl" Control.Monad.Reader
87import Control.Concurrent
88import Control.Concurrent.STM
89import qualified Control.Monad.Fail as Fail
90import qualified Data.Map.Strict as M
91import qualified Data.Set as S
92import Data.Time.Clock.POSIX
93
94{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar,
95 - and an AnnexRead. The MVar is not exposed outside this module.
96 -
97 - Note that when an Annex action fails and the exception is caught,
98 - any changes the action has made to the AnnexState are retained,
99 - due to the use of the MVar to store the state.
100 -}
101newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState, AnnexRead) IO a }
102	deriving (
103		Monad,
104		MonadIO,
105		MonadReader (MVar AnnexState, AnnexRead),
106		MonadCatch,
107		MonadThrow,
108		MonadMask,
109		Fail.MonadFail,
110		Functor,
111		Applicative,
112		Alternative
113	)
114
115-- Values that can be read, but not modified by an Annex action.
116data AnnexRead = AnnexRead
117	{ activekeys :: TVar (M.Map Key ThreadId)
118	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
119	, keysdbhandle :: Keys.DbHandle
120	, sshstalecleaned :: TMVar Bool
121	, signalactions :: TVar (M.Map SignalAction (Int -> IO ()))
122	, transferrerpool :: TransferrerPool
123	, debugenabled :: Bool
124	, debugselector :: DebugSelector
125	, ciphers :: TMVar (M.Map StorableCipher Cipher)
126	}
127
128newAnnexRead :: GitConfig -> IO AnnexRead
129newAnnexRead c = do
130	emptyactivekeys <- newTVarIO M.empty
131	emptyactiveremotes <- newMVar M.empty
132	kh <- Keys.newDbHandle
133	sc <- newTMVarIO False
134	si <- newTVarIO M.empty
135	tp <- newTransferrerPool
136	cm <- newTMVarIO M.empty
137	return $ AnnexRead
138		{ activekeys = emptyactivekeys
139		, activeremotes = emptyactiveremotes
140		, keysdbhandle = kh
141		, sshstalecleaned = sc
142		, signalactions = si
143		, transferrerpool = tp
144		, debugenabled = annexDebug c
145		, debugselector = debugSelectorFromGitConfig c
146		, ciphers = cm
147		}
148
149-- Values that can change while running an Annex action.
150data AnnexState = AnnexState
151	{ repo :: Git.Repo
152	, repoadjustment :: (Git.Repo -> IO Git.Repo)
153	, gitconfig :: GitConfig
154	, gitconfigadjustment :: (GitConfig -> GitConfig)
155	, gitconfigoverride :: [String]
156	, gitremotes :: Maybe [Git.Repo]
157	, backend :: Maybe (BackendA Annex)
158	, remotes :: [Types.Remote.RemoteA Annex]
159	, output :: MessageState
160	, concurrency :: ConcurrencySetting
161	, force :: Bool
162	, fast :: Bool
163	, daemon :: Bool
164	, branchstate :: BranchState
165	, repoqueue :: Maybe (Git.Queue.Queue Annex)
166	, catfilehandles :: CatFileHandles
167	, hashobjecthandle :: Maybe HashObjectHandle
168	, checkattrhandle :: Maybe (ResourcePool CheckAttrHandle)
169	, checkignorehandle :: Maybe (ResourcePool CheckIgnoreHandle)
170	, forcebackend :: Maybe String
171	, globalnumcopies :: Maybe NumCopies
172	, globalmincopies :: Maybe MinCopies
173	, forcenumcopies :: Maybe NumCopies
174	, forcemincopies :: Maybe MinCopies
175	, limit :: ExpandableMatcher Annex
176	, timelimit :: Maybe (Duration, POSIXTime)
177	, sizelimit :: Maybe (TVar Integer)
178	, uuiddescmap :: Maybe UUIDDescMap
179	, preferredcontentmap :: Maybe (FileMatcherMap Annex)
180	, requiredcontentmap :: Maybe (FileMatcherMap Annex)
181	, remoteconfigmap :: Maybe (M.Map UUID RemoteConfig)
182	, forcetrust :: TrustMap
183	, trustmap :: Maybe TrustMap
184	, groupmap :: Maybe GroupMap
185	, lockcache :: LockCache
186	, flags :: M.Map String Bool
187	, fields :: M.Map String String
188	, cleanupactions :: M.Map CleanupAction (Annex ())
189	, sentinalstatus :: Maybe SentinalStatus
190	, useragent :: Maybe String
191	, errcounter :: Integer
192	, skippedfiles :: Bool
193	, adjustedbranchrefreshcounter :: Integer
194	, unusedkeys :: Maybe (S.Set Key)
195	, tempurls :: M.Map Key URLString
196	, existinghooks :: M.Map Git.Hook.Hook Bool
197	, desktopnotify :: DesktopNotify
198	, workers :: Maybe (TMVar (WorkerPool (AnnexState, AnnexRead)))
199	, cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment))
200	, cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)])
201	, urloptions :: Maybe UrlOptions
202	, insmudgecleanfilter :: Bool
203	, getvectorclock :: IO CandidateVectorClock
204	}
205
206newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState
207newAnnexState c r = do
208	o <- newMessageState
209	vc <- startVectorClock
210	return $ AnnexState
211		{ repo = r
212		, repoadjustment = return
213		, gitconfig = c
214		, gitconfigadjustment = id
215		, gitconfigoverride = []
216		, gitremotes = Nothing
217		, backend = Nothing
218		, remotes = []
219		, output = o
220		, concurrency = ConcurrencyCmdLine NonConcurrent
221		, force = False
222		, fast = False
223		, daemon = False
224		, branchstate = startBranchState
225		, repoqueue = Nothing
226		, catfilehandles = catFileHandlesNonConcurrent
227		, hashobjecthandle = Nothing
228		, checkattrhandle = Nothing
229		, checkignorehandle = Nothing
230		, forcebackend = Nothing
231		, globalnumcopies = Nothing
232		, globalmincopies = Nothing
233		, forcenumcopies = Nothing
234		, forcemincopies = Nothing
235		, limit = BuildingMatcher []
236		, timelimit = Nothing
237		, sizelimit = Nothing
238		, uuiddescmap = Nothing
239		, preferredcontentmap = Nothing
240		, requiredcontentmap = Nothing
241		, remoteconfigmap = Nothing
242		, forcetrust = M.empty
243		, trustmap = Nothing
244		, groupmap = Nothing
245		, lockcache = M.empty
246		, flags = M.empty
247		, fields = M.empty
248		, cleanupactions = M.empty
249		, sentinalstatus = Nothing
250		, useragent = Nothing
251		, errcounter = 0
252		, skippedfiles = False
253		, adjustedbranchrefreshcounter = 0
254		, unusedkeys = Nothing
255		, tempurls = M.empty
256		, existinghooks = M.empty
257		, desktopnotify = mempty
258		, workers = Nothing
259		, cachedcurrentbranch = Nothing
260		, cachedgitenv = Nothing
261		, urloptions = Nothing
262		, insmudgecleanfilter = False
263		, getvectorclock = vc
264		}
265
266{- Makes an Annex state object for the specified git repo.
267 - Ensures the config is read, if it was not already, and performs
268 - any necessary git repo fixups. -}
269new :: Git.Repo -> IO (AnnexState, AnnexRead)
270new r = do
271	r' <- Git.Config.read r
272	let c = extractGitConfig FromGitConfig r'
273	st <- newAnnexState c =<< fixupRepo r' c
274	rd <- newAnnexRead c
275	return (st, rd)
276
277{- Performs an action in the Annex monad from a starting state,
278 - returning a new state. -}
279run :: (AnnexState, AnnexRead) -> Annex a -> IO (a, (AnnexState, AnnexRead))
280run (st, rd) a = do
281	mv <- newMVar st
282	run' mv rd a
283
284run' :: MVar AnnexState -> AnnexRead -> Annex a -> IO (a, (AnnexState, AnnexRead))
285run' mvar rd a = do
286	r <- runReaderT (runAnnex a) (mvar, rd)
287		`onException` (flush rd)
288	flush rd
289	st <- takeMVar mvar
290	return (r, (st, rd))
291  where
292	flush = Keys.flushDbQueue . keysdbhandle
293
294{- Performs an action in the Annex monad from a starting state,
295 - and throws away the changed state. -}
296eval :: (AnnexState, AnnexRead) -> Annex a -> IO a
297eval v a = fst <$> run v a
298
299{- Makes a runner action, that allows diving into IO and from inside
300 - the IO action, running an Annex action. -}
301makeRunner :: Annex (Annex a -> IO a)
302makeRunner = do
303	(mvar, rd) <- ask
304	return $ \a -> do
305		(r, (s, _rd)) <- run' mvar rd a
306		putMVar mvar s
307		return r
308
309getRead :: (AnnexRead -> v) -> Annex v
310getRead selector = selector . snd <$> ask
311
312getState :: (AnnexState -> v) -> Annex v
313getState selector = do
314	mvar <- fst <$> ask
315	st <- liftIO $ readMVar mvar
316	return $ selector st
317
318changeState :: (AnnexState -> AnnexState) -> Annex ()
319changeState modifier = do
320	mvar <- fst <$> ask
321	liftIO $ modifyMVar_ mvar $ return . modifier
322
323withState :: (AnnexState -> IO (AnnexState, b)) -> Annex b
324withState modifier = do
325	mvar <- fst <$> ask
326	liftIO $ modifyMVar mvar modifier
327
328{- Sets a flag to True -}
329setFlag :: String -> Annex ()
330setFlag flag = changeState $ \st ->
331	st { flags = M.insert flag True $ flags st }
332
333{- Sets a field to a value -}
334setField :: String -> String -> Annex ()
335setField field value = changeState $ \st ->
336	st { fields = M.insert field value $ fields st }
337
338{- Adds a cleanup action to perform. -}
339addCleanupAction :: CleanupAction -> Annex () -> Annex ()
340addCleanupAction k a = changeState $ \st ->
341	st { cleanupactions = M.insert k a $ cleanupactions st }
342
343{- Sets the type of output to emit. -}
344setOutput :: OutputType -> Annex ()
345setOutput o = changeState $ \st ->
346	let m = output st
347	in st { output = m { outputType = adjustOutputType (outputType m) o } }
348
349{- Checks if a flag was set. -}
350getFlag :: String -> Annex Bool
351getFlag flag = fromMaybe False . M.lookup flag <$> getState flags
352
353{- Gets the value of a field. -}
354getField :: String -> Annex (Maybe String)
355getField field = M.lookup field <$> getState fields
356
357{- Returns the annex's git repository. -}
358gitRepo :: Annex Git.Repo
359gitRepo = getState repo
360
361{- Runs an IO action in the annex's git repository. -}
362inRepo :: (Git.Repo -> IO a) -> Annex a
363inRepo a = liftIO . a =<< gitRepo
364
365{- Extracts a value from the annex's git repisitory. -}
366fromRepo :: (Git.Repo -> a) -> Annex a
367fromRepo a = a <$> gitRepo
368
369{- Calculates a value from an annex's git repository and its GitConfig. -}
370calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a
371calcRepo a = do
372	s <- getState id
373	liftIO $ a (repo s) (gitconfig s)
374
375{- Gets the GitConfig settings. -}
376getGitConfig :: Annex GitConfig
377getGitConfig = getState gitconfig
378
379{- Overrides a GitConfig setting. The modification persists across
380 - reloads of the repo's config. -}
381overrideGitConfig :: (GitConfig -> GitConfig) -> Annex ()
382overrideGitConfig f = changeState $ \st -> st
383	{ gitconfigadjustment = gitconfigadjustment st . f
384	, gitconfig = f (gitconfig st)
385	}
386
387{- Adds an adjustment to the Repo data. Adjustments persist across reloads
388 - of the repo's config.
389 -
390 - Note that the action may run more than once, and should avoid eg,
391 - appending the same value to a repo's config when run repeatedly.
392 -}
393adjustGitRepo :: (Git.Repo -> IO Git.Repo) -> Annex ()
394adjustGitRepo a = do
395	changeState $ \st -> st { repoadjustment = \r -> repoadjustment st r >>= a }
396	changeGitRepo =<< gitRepo
397
398{- Adds git config setting, like "foo=bar". It will be passed with -c
399 - to git processes. The config setting is also recorded in the Repo,
400 - and the GitConfig is updated. -}
401addGitConfigOverride :: String -> Annex ()
402addGitConfigOverride v = do
403	adjustGitRepo $ \r ->
404		Git.Config.store (encodeBS v) Git.Config.ConfigList $
405			r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }
406	changeState $ \st -> st { gitconfigoverride = v : gitconfigoverride st }
407  where
408	-- Remove any prior occurrance of the setting to avoid
409	-- building up many of them when the adjustment is run repeatedly,
410	-- and add the setting to the end.
411	go [] = [Param "-c", Param v]
412	go (Param "-c": Param v':rest) | v' == v = go rest
413	go (c:rest) = c : go rest
414
415{- Values that were passed to addGitConfigOverride. -}
416getGitConfigOverrides :: Annex [String]
417getGitConfigOverrides = reverse <$> getState gitconfigoverride
418
419{- Changing the git Repo data also involves re-extracting its GitConfig. -}
420changeGitRepo :: Git.Repo -> Annex ()
421changeGitRepo r = do
422	repoadjuster <- getState repoadjustment
423	gitconfigadjuster <- getState gitconfigadjustment
424	r' <- liftIO $ repoadjuster r
425	changeState $ \st -> st
426		{ repo = r'
427		, gitconfig = gitconfigadjuster $
428			extractGitConfig FromGitConfig r'
429		}
430
431{- Gets the RemoteGitConfig from a remote, given the Git.Repo for that
432 - remote. -}
433getRemoteGitConfig :: Git.Repo -> Annex RemoteGitConfig
434getRemoteGitConfig r = do
435	g <- gitRepo
436	liftIO $ atomically $ extractRemoteGitConfig g (Git.repoDescribe r)
437
438{- Converts an Annex action into an IO action, that runs with a copy
439 - of the current Annex state.
440 -
441 - Use with caution; the action should not rely on changing the
442 - state, as it will be thrown away. -}
443withCurrentState :: Annex a -> Annex (IO a)
444withCurrentState a = do
445	(mvar, rd) <- ask
446	st <- liftIO $ readMVar mvar
447	return $ eval (st, rd) a
448
449{- It's not safe to use setCurrentDirectory in the Annex monad,
450 - because the git repo paths are stored relative.
451 - Instead, use this.
452 -}
453changeDirectory :: FilePath -> Annex ()
454changeDirectory d = do
455	r <- liftIO . Git.adjustPath absPath =<< gitRepo
456	liftIO $ setCurrentDirectory d
457	r' <- liftIO $ Git.relPath r
458	changeState $ \st -> st { repo = r' }
459
460incError :: Annex ()
461incError = changeState $ \st ->
462	let !c = errcounter st + 1
463	    !st' = st { errcounter = c }
464	in st'
465
466getGitRemotes :: Annex [Git.Repo]
467getGitRemotes = do
468	st <- getState id
469	case gitremotes st of
470		Just rs -> return rs
471		Nothing -> do
472			rs <- liftIO $ Git.Construct.fromRemotes (repo st)
473			changeState $ \st' -> st' { gitremotes = Just rs }
474			return rs
475