7a6fb8ae4e
This allows the queue to be used in a single process for multiple possibly conflicting commands, like add and rm, without running them out of order. This assumes that running the same git subcommand with different parameters cannot itself conflict.
107 lines
3.1 KiB
Haskell
107 lines
3.1 KiB
Haskell
{- git repository command queue
|
|
-
|
|
- Copyright 2010,2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
module Git.Queue (
|
|
Queue,
|
|
new,
|
|
add,
|
|
size,
|
|
full,
|
|
flush,
|
|
) where
|
|
|
|
import qualified Data.Map as M
|
|
import System.IO
|
|
import System.Cmd.Utils
|
|
import Data.String.Utils
|
|
|
|
import Utility.SafeCommand
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
|
|
{- An action to perform in a git repository. The file to act on
|
|
- is not included, and must be able to be appended after the params. -}
|
|
data Action = Action
|
|
{ getSubcommand :: String
|
|
, getParams :: [CommandParam]
|
|
} deriving (Show, Eq, Ord)
|
|
|
|
{- Compares two actions by subcommand. -}
|
|
(===) :: Action -> Action -> Bool
|
|
a === b = getSubcommand a == getSubcommand b
|
|
(/==) :: Action -> Action -> Bool
|
|
a /== b = not $ a === b
|
|
|
|
{- A queue of actions to perform (in any order) on a git repository,
|
|
- with lists of files to perform them on. This allows coalescing
|
|
- similar git commands. -}
|
|
data Queue = Queue
|
|
{ size :: Int
|
|
, _limit :: Int
|
|
, _items :: M.Map Action [FilePath]
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
{- A recommended maximum size for the queue, after which it should be
|
|
- run.
|
|
-
|
|
- 10240 is semi-arbitrary. If we assume git filenames are between 10 and
|
|
- 255 characters long, then the queue will build up between 100kb and
|
|
- 2550kb long commands. The max command line length on linux is somewhere
|
|
- above 20k, so this is a fairly good balance -- the queue will buffer
|
|
- only a few megabytes of stuff and a minimal number of commands will be
|
|
- run by xargs. -}
|
|
defaultLimit :: Int
|
|
defaultLimit = 10240
|
|
|
|
{- Constructor for empty queue. -}
|
|
new :: Maybe Int -> Queue
|
|
new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
|
|
|
|
{- Adds an action to a 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. -}
|
|
add :: Queue -> String -> [CommandParam] -> [FilePath] -> Repo -> IO Queue
|
|
add q@(Queue _ _ m) subcommand params files repo
|
|
| null (filter (/== action) (M.keys m)) = go q
|
|
| otherwise = go =<< flush q repo
|
|
where
|
|
action = Action subcommand params
|
|
go (Queue cur lim m') =
|
|
return $ Queue (cur + 1) lim $
|
|
M.insertWith' const action fs m'
|
|
where
|
|
!fs = files ++ M.findWithDefault [] action m'
|
|
|
|
{- Is a queue large enough that it should be flushed? -}
|
|
full :: Queue -> Bool
|
|
full (Queue cur lim _) = cur > lim
|
|
|
|
{- Runs a queue on a git repository. -}
|
|
flush :: Queue -> Repo -> IO Queue
|
|
flush (Queue _ lim m) repo = do
|
|
forM_ (M.toList m) $ uncurry $ runAction repo
|
|
return $ Queue 0 lim M.empty
|
|
|
|
{- Runs an Action on a list of files in a git repository.
|
|
-
|
|
- Complicated by commandline length limits.
|
|
-
|
|
- Intentionally runs the command even if the list of files is empty;
|
|
- this allows queueing commands that do not need a list of files. -}
|
|
runAction :: Repo -> Action -> [FilePath] -> IO ()
|
|
runAction repo action files =
|
|
pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
|
|
where
|
|
params = toCommand $ gitCommandLine
|
|
(Param (getSubcommand action):getParams action) repo
|
|
feedxargs h = do
|
|
fileEncoding h
|
|
hPutStr h $ join "\0" files
|