extend Git.Queue to be able to queue more than simple git commands
While I was in there, I noticed and fixed a bug in the queue size calculations. It was never encountered only because Queue.add was only ever run with 1 file in the list.
This commit is contained in:
parent
727158ff55
commit
0a11b35d89
8 changed files with 94 additions and 43 deletions
|
@ -6,7 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Annex.Queue (
|
module Annex.Queue (
|
||||||
add,
|
addCommand,
|
||||||
flush,
|
flush,
|
||||||
flushWhenFull
|
flushWhenFull
|
||||||
) where
|
) where
|
||||||
|
@ -17,10 +17,10 @@ import qualified Git.Queue
|
||||||
import Config
|
import Config
|
||||||
|
|
||||||
{- Adds a git command to the queue. -}
|
{- Adds a git command to the queue. -}
|
||||||
add :: String -> [CommandParam] -> [FilePath] -> Annex ()
|
addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
|
||||||
add command params files = do
|
addCommand command params files = do
|
||||||
q <- get
|
q <- get
|
||||||
store =<< inRepo (Git.Queue.add q command params files)
|
store =<< inRepo (Git.Queue.addCommand command params files q)
|
||||||
|
|
||||||
{- Runs the queue if it is full. Should be called periodically. -}
|
{- Runs the queue if it is full. Should be called periodically. -}
|
||||||
flushWhenFull :: Annex ()
|
flushWhenFull :: Annex ()
|
||||||
|
|
|
@ -121,5 +121,5 @@ cleanup file key hascontent = do
|
||||||
( return [Param "-f"]
|
( return [Param "-f"]
|
||||||
, return []
|
, return []
|
||||||
)
|
)
|
||||||
Annex.Queue.add "add" (params++[Param "--"]) [file]
|
Annex.Queue.addCommand "add" (params++[Param "--"]) [file]
|
||||||
return True
|
return True
|
||||||
|
|
|
@ -36,5 +36,5 @@ perform file link = do
|
||||||
|
|
||||||
cleanup :: FilePath -> CommandCleanup
|
cleanup :: FilePath -> CommandCleanup
|
||||||
cleanup file = do
|
cleanup file = do
|
||||||
Annex.Queue.add "add" [Param "--force", Param "--"] [file]
|
Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file]
|
||||||
return True
|
return True
|
||||||
|
|
|
@ -39,5 +39,5 @@ perform key file = do
|
||||||
|
|
||||||
cleanup :: FilePath -> CommandCleanup
|
cleanup :: FilePath -> CommandCleanup
|
||||||
cleanup file = do
|
cleanup file = do
|
||||||
Annex.Queue.add "add" [Param "--"] [file]
|
Annex.Queue.addCommand "add" [Param "--"] [file]
|
||||||
return True
|
return True
|
||||||
|
|
|
@ -155,7 +155,7 @@ fixLink key file = do
|
||||||
liftIO $ createDirectoryIfMissing True (parentDir file)
|
liftIO $ createDirectoryIfMissing True (parentDir file)
|
||||||
liftIO $ removeFile file
|
liftIO $ removeFile file
|
||||||
liftIO $ createSymbolicLink want file
|
liftIO $ createSymbolicLink want file
|
||||||
Annex.Queue.add "add" [Param "--force", Param "--"] [file]
|
Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file]
|
||||||
return True
|
return True
|
||||||
|
|
||||||
{- Checks that the location log reflects the current status of the key,
|
{- Checks that the location log reflects the current status of the key,
|
||||||
|
|
|
@ -24,5 +24,5 @@ start file = do
|
||||||
|
|
||||||
perform :: FilePath -> CommandPerform
|
perform :: FilePath -> CommandPerform
|
||||||
perform file = do
|
perform file = do
|
||||||
Annex.Queue.add "checkout" [Param "--"] [file]
|
Annex.Queue.addCommand "checkout" [Param "--"] [file]
|
||||||
next $ return True -- no cleanup needed
|
next $ return True -- no cleanup needed
|
||||||
|
|
105
Git/Queue.hs
105
Git/Queue.hs
|
@ -10,7 +10,8 @@
|
||||||
module Git.Queue (
|
module Git.Queue (
|
||||||
Queue,
|
Queue,
|
||||||
new,
|
new,
|
||||||
add,
|
addCommand,
|
||||||
|
addUpdateIndex,
|
||||||
size,
|
size,
|
||||||
full,
|
full,
|
||||||
flush,
|
flush,
|
||||||
|
@ -25,19 +26,31 @@ import Utility.SafeCommand
|
||||||
import Common
|
import Common
|
||||||
import Git
|
import Git
|
||||||
import Git.Command
|
import Git.Command
|
||||||
|
import qualified Git.UpdateIndex
|
||||||
|
|
||||||
{- An action to perform in a git repository. The file to act on
|
{- Queable actions that can be performed in a git repository.
|
||||||
- is not included, and must be able to be appended after the params. -}
|
-}
|
||||||
data Action = Action
|
data Action
|
||||||
|
{- Updating the index file, using a list of streamers that can
|
||||||
|
- be added to as the queue grows. -}
|
||||||
|
= UpdateIndexAction
|
||||||
|
{ getStreamers :: [Git.UpdateIndex.Streamer]
|
||||||
|
}
|
||||||
|
{- A git command to run, on a list of files that can be added to
|
||||||
|
- as the queue grows. -}
|
||||||
|
| CommandAction
|
||||||
{ getSubcommand :: String
|
{ getSubcommand :: String
|
||||||
, getParams :: [CommandParam]
|
, getParams :: [CommandParam]
|
||||||
} deriving (Show, Eq, Ord)
|
, getFiles :: [FilePath]
|
||||||
|
}
|
||||||
|
|
||||||
{- Compares two actions by subcommand. -}
|
{- A key that can uniquely represent an action in a Map. -}
|
||||||
(===) :: Action -> Action -> Bool
|
data ActionKey = UpdateIndexActionKey | CommandActionKey String
|
||||||
a === b = getSubcommand a == getSubcommand b
|
deriving (Eq, Ord)
|
||||||
(/==) :: Action -> Action -> Bool
|
|
||||||
a /== b = not $ a === b
|
actionKey :: Action -> ActionKey
|
||||||
|
actionKey (UpdateIndexAction _) = UpdateIndexActionKey
|
||||||
|
actionKey CommandAction { getSubcommand = s } = CommandActionKey s
|
||||||
|
|
||||||
{- A queue of actions to perform (in any order) on a git repository,
|
{- A queue of actions to perform (in any order) on a git repository,
|
||||||
- with lists of files to perform them on. This allows coalescing
|
- with lists of files to perform them on. This allows coalescing
|
||||||
|
@ -45,9 +58,8 @@ a /== b = not $ a === b
|
||||||
data Queue = Queue
|
data Queue = Queue
|
||||||
{ size :: Int
|
{ size :: Int
|
||||||
, _limit :: Int
|
, _limit :: Int
|
||||||
, _items :: M.Map Action [FilePath]
|
, items :: M.Map ActionKey Action
|
||||||
}
|
}
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
{- A recommended maximum size for the queue, after which it should be
|
{- A recommended maximum size for the queue, after which it should be
|
||||||
- run.
|
- run.
|
||||||
|
@ -65,20 +77,58 @@ defaultLimit = 10240
|
||||||
new :: Maybe Int -> Queue
|
new :: Maybe Int -> Queue
|
||||||
new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
|
new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
|
||||||
|
|
||||||
{- Adds an action to a queue. If the queue already contains a different
|
{- Adds a command to a queue. If the queue already contains a different
|
||||||
- action, it will be flushed; this is to ensure that conflicting actions,
|
- action, it will be flushed; this is to ensure that conflicting actions,
|
||||||
- like add and rm, are run in the right order. -}
|
- like add and rm, are run in the right order.
|
||||||
add :: Queue -> String -> [CommandParam] -> [FilePath] -> Repo -> IO Queue
|
-
|
||||||
add q@(Queue _ _ m) subcommand params files repo
|
- Actions with the same subcommand but different parameters are
|
||||||
| null (filter (/== action) (M.keys m)) = go q
|
- roughly equivilant; assumed equivilant enough to perform in any order
|
||||||
| otherwise = go =<< flush q repo
|
- with the same result.
|
||||||
|
-}
|
||||||
|
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
|
||||||
|
addCommand subcommand params files q repo =
|
||||||
|
updateQueue action different (length newfiles) q repo
|
||||||
where
|
where
|
||||||
action = Action subcommand params
|
key = actionKey action
|
||||||
go (Queue cur lim m') =
|
action = CommandAction
|
||||||
return $ Queue (cur + 1) lim $
|
{ getSubcommand = subcommand
|
||||||
M.insertWith' const action fs m'
|
, getParams = params
|
||||||
|
, getFiles = newfiles
|
||||||
|
}
|
||||||
|
newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
|
||||||
|
|
||||||
|
different (CommandAction { getSubcommand = s }) = s /= subcommand
|
||||||
|
different _ = True
|
||||||
|
|
||||||
|
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
|
||||||
|
addUpdateIndex streamer q repo =
|
||||||
|
updateQueue action different 0 q repo
|
||||||
where
|
where
|
||||||
!fs = files ++ M.findWithDefault [] action m'
|
key = actionKey action
|
||||||
|
-- streamer is added to the end of the list, since
|
||||||
|
-- order does matter for update-index input
|
||||||
|
action = UpdateIndexAction $ streamers ++ [streamer]
|
||||||
|
streamers = maybe [] getStreamers $ M.lookup key $ items q
|
||||||
|
|
||||||
|
different (UpdateIndexAction _) = False
|
||||||
|
different _ = True
|
||||||
|
|
||||||
|
{- Updates or adds an action in the queue. If the queue already contains a
|
||||||
|
- different action, it will be flushed; this is to ensure that conflicting
|
||||||
|
- actions, like add and rm, are run in the right order.-}
|
||||||
|
updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue
|
||||||
|
updateQueue action different sizeincrease q repo
|
||||||
|
| null (filter different (M.elems (items q))) = return $ go q
|
||||||
|
| otherwise = go <$> flush q repo
|
||||||
|
where
|
||||||
|
go q' = newq
|
||||||
|
where
|
||||||
|
!newq = q'
|
||||||
|
{ size = newsize
|
||||||
|
, items = newitems
|
||||||
|
}
|
||||||
|
!newsize = size q' + sizeincrease
|
||||||
|
!newitems = M.insertWith' const (actionKey action) action (items q')
|
||||||
|
|
||||||
{- Is a queue large enough that it should be flushed? -}
|
{- Is a queue large enough that it should be flushed? -}
|
||||||
full :: Queue -> Bool
|
full :: Queue -> Bool
|
||||||
|
@ -87,7 +137,7 @@ full (Queue cur lim _) = cur > lim
|
||||||
{- Runs a queue on a git repository. -}
|
{- Runs a queue on a git repository. -}
|
||||||
flush :: Queue -> Repo -> IO Queue
|
flush :: Queue -> Repo -> IO Queue
|
||||||
flush (Queue _ lim m) repo = do
|
flush (Queue _ lim m) repo = do
|
||||||
forM_ (M.toList m) $ uncurry $ runAction repo
|
forM_ (M.elems m) $ runAction repo
|
||||||
return $ Queue 0 lim M.empty
|
return $ Queue 0 lim M.empty
|
||||||
|
|
||||||
{- Runs an Action on a list of files in a git repository.
|
{- Runs an Action on a list of files in a git repository.
|
||||||
|
@ -96,12 +146,13 @@ flush (Queue _ lim m) repo = do
|
||||||
-
|
-
|
||||||
- Intentionally runs the command even if the list of files is empty;
|
- Intentionally runs the command even if the list of files is empty;
|
||||||
- this allows queueing commands that do not need a list of files. -}
|
- this allows queueing commands that do not need a list of files. -}
|
||||||
runAction :: Repo -> Action -> [FilePath] -> IO ()
|
runAction :: Repo -> Action -> IO ()
|
||||||
runAction repo action files =
|
runAction _repo _action@(UpdateIndexAction {}) = error "TODO"
|
||||||
|
runAction repo action@(CommandAction {}) =
|
||||||
pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
|
pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
|
||||||
where
|
where
|
||||||
params = toCommand $ gitCommandLine
|
params = toCommand $ gitCommandLine
|
||||||
(Param (getSubcommand action):getParams action) repo
|
(Param (getSubcommand action):getParams action) repo
|
||||||
feedxargs h = do
|
feedxargs h = do
|
||||||
fileEncoding h
|
fileEncoding h
|
||||||
hPutStr h $ join "\0" files
|
hPutStr h $ join "\0" $ getFiles action
|
||||||
|
|
|
@ -94,7 +94,7 @@ updateSymlinks = do
|
||||||
link <- calcGitLink f k
|
link <- calcGitLink f k
|
||||||
liftIO $ removeFile f
|
liftIO $ removeFile f
|
||||||
liftIO $ createSymbolicLink link f
|
liftIO $ createSymbolicLink link f
|
||||||
Annex.Queue.add "add" [Param "--"] [f]
|
Annex.Queue.addCommand "add" [Param "--"] [f]
|
||||||
|
|
||||||
moveLocationLogs :: Annex ()
|
moveLocationLogs :: Annex ()
|
||||||
moveLocationLogs = do
|
moveLocationLogs = do
|
||||||
|
@ -121,9 +121,9 @@ moveLocationLogs = do
|
||||||
old <- liftIO $ readLog1 f
|
old <- liftIO $ readLog1 f
|
||||||
new <- liftIO $ readLog1 dest
|
new <- liftIO $ readLog1 dest
|
||||||
liftIO $ writeLog1 dest (old++new)
|
liftIO $ writeLog1 dest (old++new)
|
||||||
Annex.Queue.add "add" [Param "--"] [dest]
|
Annex.Queue.addCommand "add" [Param "--"] [dest]
|
||||||
Annex.Queue.add "add" [Param "--"] [f]
|
Annex.Queue.addCommand "add" [Param "--"] [f]
|
||||||
Annex.Queue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f]
|
Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f]
|
||||||
|
|
||||||
oldlog2key :: FilePath -> Maybe (FilePath, Key)
|
oldlog2key :: FilePath -> Maybe (FilePath, Key)
|
||||||
oldlog2key l
|
oldlog2key l
|
||||||
|
|
Loading…
Reference in a new issue