2011-04-07 17:59:31 +00:00
|
|
|
{- git-annex command queue
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2011, 2012 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)
|
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
|
|
|
|
2018-08-28 17:14:44 +00:00
|
|
|
import qualified Control.Concurrent.SSem as SSem
|
|
|
|
|
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
|
2016-01-13 18:55:01 +00:00
|
|
|
store <=< flushWhenFull <=< inRepo $
|
|
|
|
Git.Queue.addCommand command params files q
|
2011-04-07 17:59:31 +00:00
|
|
|
|
2018-08-17 20:03:40 +00:00
|
|
|
addInternalAction :: Git.Queue.InternalActionRunner -> [(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
|
|
|
|
store <=< flushWhenFull <=< inRepo $
|
2018-08-17 17:24:52 +00:00
|
|
|
Git.Queue.addInternalAction runner files q
|
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
|
2016-01-13 18:55:01 +00:00
|
|
|
store <=< flushWhenFull <=< inRepo $
|
|
|
|
Git.Queue.addUpdateIndex streamer q
|
2012-06-07 19:40:44 +00:00
|
|
|
|
2016-01-13 18:55:01 +00:00
|
|
|
{- Runs the queue if it is full. -}
|
|
|
|
flushWhenFull :: Git.Queue.Queue -> Annex Git.Queue.Queue
|
|
|
|
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.
|
|
|
|
-
|
|
|
|
- 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.
|
|
|
|
- The repoqueuesem is shared between threads.
|
|
|
|
-}
|
2016-01-13 18:55:01 +00:00
|
|
|
flush' :: Git.Queue.Queue -> Annex Git.Queue.Queue
|
2018-08-28 17:14:44 +00:00
|
|
|
flush' q = bracket lock unlock go
|
|
|
|
where
|
|
|
|
lock = do
|
|
|
|
s <- getState repoqueuesem
|
|
|
|
liftIO $ SSem.wait s
|
|
|
|
return s
|
|
|
|
unlock = liftIO . SSem.signal
|
|
|
|
go _ = do
|
|
|
|
showStoringStateAction
|
|
|
|
inRepo $ Git.Queue.flush q
|
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
|
|
|
|
|
2012-02-15 15:13:13 +00:00
|
|
|
get :: Annex Git.Queue.Queue
|
|
|
|
get = maybe new return =<< getState repoqueue
|
|
|
|
|
|
|
|
new :: Annex Git.Queue.Queue
|
|
|
|
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
|
|
|
|
|
2011-06-30 17:25:37 +00:00
|
|
|
store :: Git.Queue.Queue -> 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'
|