2011-04-07 17:59:31 +00:00
|
|
|
{- git-annex command queue
|
|
|
|
-
|
2019-05-06 19:15:12 +00:00
|
|
|
- Copyright 2011, 2012, 2019 Joey Hess <id@joeyh.name>
|
2011-04-07 17:59:31 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2011-04-07 17:59:31 +00:00
|
|
|
-}
|
|
|
|
|
2015-11-05 22:21:48 +00:00
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
|
2011-10-04 04:40:47 +00:00
|
|
|
module Annex.Queue (
|
2012-06-07 19:19:44 +00:00
|
|
|
addCommand,
|
2018-08-17 17:24:52 +00:00
|
|
|
addInternalAction,
|
2012-06-07 19:40:44 +00:00
|
|
|
addUpdateIndex,
|
2011-04-07 17:59:31 +00:00
|
|
|
flush,
|
2012-06-10 17:56:04 +00:00
|
|
|
flushWhenFull,
|
2015-11-05 22:21:48 +00:00
|
|
|
size,
|
withAltRepo needs a separate queue of changes
The queue could potentially contain changes from before withAltRepo, and
get flushed inside the call, which would apply the changes to the modified
repo.
Or, changes could be queued in withAltRepo that were intended to affect
the modified repo, but don't get flushed until later.
I don't know of any cases where either happens, but better safe than sorry.
Note that this affect withIndexFile, which is used in git-annex branch
updates. So, it potentially makes things slower. Should not be by much;
the overhead consists only of querying the current queue a couple of times,
and potentially flushing changes queued within withAltRepo earlier, that
could have maybe been bundled with other later changes.
Notice in particular that the existing queue is not flushed when calling
withAltRepo. So eg when git annex add needs to stage files in the index,
it will still bundle them together efficiently.
2016-06-03 17:48:14 +00:00
|
|
|
get,
|
2015-11-05 22:21:48 +00:00
|
|
|
mergeFrom,
|
2011-04-07 17:59:31 +00:00
|
|
|
) where
|
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2012-02-15 15:13:13 +00:00
|
|
|
import Annex hiding (new)
|
2019-05-06 19:15:12 +00:00
|
|
|
import Annex.LockFile
|
2011-06-30 17:25:37 +00:00
|
|
|
import qualified Git.Queue
|
2012-06-07 19:40:44 +00:00
|
|
|
import qualified Git.UpdateIndex
|
2011-04-07 17:59:31 +00:00
|
|
|
|
2011-08-21 16:59:49 +00:00
|
|
|
{- Adds a git command to the queue. -}
|
2012-06-07 19:19:44 +00:00
|
|
|
addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
|
|
|
|
addCommand command params files = do
|
2012-02-15 15:13:13 +00:00
|
|
|
q <- get
|
2019-11-12 14:44:51 +00:00
|
|
|
store =<< flushWhenFull =<<
|
|
|
|
(Git.Queue.addCommand command params files q =<< gitRepo)
|
2011-04-07 17:59:31 +00:00
|
|
|
|
2019-11-12 14:44:51 +00:00
|
|
|
addInternalAction :: Git.Queue.InternalActionRunner Annex -> [(FilePath, IO Bool)] -> Annex ()
|
2018-08-17 17:24:52 +00:00
|
|
|
addInternalAction runner files = do
|
2018-08-16 19:15:20 +00:00
|
|
|
q <- get
|
2019-11-12 14:44:51 +00:00
|
|
|
store =<< flushWhenFull =<<
|
|
|
|
(Git.Queue.addInternalAction runner files q =<< gitRepo)
|
2018-08-16 19:15:20 +00:00
|
|
|
|
2012-06-07 19:40:44 +00:00
|
|
|
{- Adds an update-index stream to the queue. -}
|
|
|
|
addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
|
|
|
|
addUpdateIndex streamer = do
|
|
|
|
q <- get
|
2019-11-12 14:44:51 +00:00
|
|
|
store =<< flushWhenFull =<<
|
|
|
|
(Git.Queue.addUpdateIndex streamer q =<< gitRepo)
|
2012-06-07 19:40:44 +00:00
|
|
|
|
2016-01-13 18:55:01 +00:00
|
|
|
{- Runs the queue if it is full. -}
|
2019-11-12 14:44:51 +00:00
|
|
|
flushWhenFull :: Git.Queue.Queue Annex -> Annex (Git.Queue.Queue Annex)
|
2016-01-13 18:55:01 +00:00
|
|
|
flushWhenFull q
|
|
|
|
| Git.Queue.full q = flush' q
|
|
|
|
| otherwise = return q
|
2011-04-07 17:59:31 +00:00
|
|
|
|
|
|
|
{- Runs (and empties) the queue. -}
|
2012-04-27 17:23:52 +00:00
|
|
|
flush :: Annex ()
|
|
|
|
flush = do
|
2012-02-15 15:13:13 +00:00
|
|
|
q <- get
|
2011-06-30 17:25:37 +00:00
|
|
|
unless (0 == Git.Queue.size q) $ do
|
2016-01-13 18:55:01 +00:00
|
|
|
store =<< flush' q
|
|
|
|
|
2018-08-28 17:14:44 +00:00
|
|
|
{- When there are multiple worker threads, each has its own queue.
|
2019-05-06 19:15:12 +00:00
|
|
|
- And of course multiple git-annex processes may be running each with its
|
|
|
|
- own queue.
|
2018-08-28 17:14:44 +00:00
|
|
|
-
|
|
|
|
- But, flushing two queues at the same time could lead to failures due to
|
|
|
|
- git locking files. So, only one queue is allowed to flush at a time.
|
|
|
|
-}
|
2019-11-12 14:44:51 +00:00
|
|
|
flush' :: Git.Queue.Queue Annex -> Annex (Git.Queue.Queue Annex)
|
2019-05-06 19:15:12 +00:00
|
|
|
flush' q = withExclusiveLock gitAnnexGitQueueLock $ do
|
|
|
|
showStoringStateAction
|
2019-11-12 14:44:51 +00:00
|
|
|
Git.Queue.flush q =<< gitRepo
|
2011-04-07 17:59:31 +00:00
|
|
|
|
2012-06-10 17:56:04 +00:00
|
|
|
{- Gets the size of the queue. -}
|
|
|
|
size :: Annex Int
|
|
|
|
size = Git.Queue.size <$> get
|
|
|
|
|
2019-11-12 14:44:51 +00:00
|
|
|
get :: Annex (Git.Queue.Queue Annex)
|
2012-02-15 15:13:13 +00:00
|
|
|
get = maybe new return =<< getState repoqueue
|
|
|
|
|
2019-11-12 14:44:51 +00:00
|
|
|
new :: Annex (Git.Queue.Queue Annex)
|
2012-02-15 15:13:13 +00:00
|
|
|
new = do
|
2013-01-01 17:52:47 +00:00
|
|
|
q <- Git.Queue.new . annexQueueSize <$> getGitConfig
|
2012-02-15 15:13:13 +00:00
|
|
|
store q
|
|
|
|
return q
|
|
|
|
|
2019-11-12 14:44:51 +00:00
|
|
|
store :: Git.Queue.Queue Annex -> Annex ()
|
2012-02-15 15:13:13 +00:00
|
|
|
store q = changeState $ \s -> s { repoqueue = Just q }
|
2015-11-05 22:21:48 +00:00
|
|
|
|
|
|
|
mergeFrom :: AnnexState -> Annex ()
|
|
|
|
mergeFrom st = case repoqueue st of
|
|
|
|
Nothing -> noop
|
|
|
|
Just newq -> do
|
|
|
|
q <- get
|
|
|
|
let !q' = Git.Queue.merge q newq
|
2016-01-13 18:55:01 +00:00
|
|
|
store =<< flushWhenFull q'
|