1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{- 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
|
