1{- git repository command queue
2 -
3 - Copyright 2010-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE CPP, BangPatterns #-}
9
10module Git.Queue (
11	Queue,
12	new,
13	addCommand,
14	addUpdateIndex,
15	addInternalAction,
16	InternalActionRunner(..),
17	size,
18	full,
19	flush,
20	merge,
21) where
22
23import Utility.SafeCommand
24import Common
25import Git
26import Git.Command
27import qualified Git.UpdateIndex
28
29import qualified Data.Map.Strict as M
30import Control.Monad.IO.Class
31
32{- Queable actions that can be performed in a git repository. -}
33data Action m
34	{- Updating the index file, using a list of streamers that can
35	 - be added to as the queue grows. -}
36	= UpdateIndexAction [Git.UpdateIndex.Streamer] -- in reverse order
37	{- A git command to run, on a list of files that can be added to
38	 - as the queue grows. -}
39	| CommandAction
40		{ getCommonParams :: [CommandParam]
41		-- ^ parameters that come before the git subcommand
42		-- (in addition to the Repo's gitGlobalOpts.
43		, getSubcommand :: String
44		, getParams :: [CommandParam]
45		-- ^ parameters that come after the git subcommand
46		, getFiles :: [CommandParam]
47		}
48	{- An internal action to run, on a list of files that can be added
49	 - to as the queue grows. -}
50	| InternalAction
51		{ getRunner :: InternalActionRunner m
52		, getInternalFiles :: [(RawFilePath, IO Bool)]
53		}
54
55{- The String must be unique for each internal action. -}
56data InternalActionRunner m = InternalActionRunner String (Repo -> [(RawFilePath, IO Bool)] -> m ())
57
58instance Eq (InternalActionRunner m) where
59	InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2
60
61{- A key that can uniquely represent an action in a Map. -}
62data ActionKey
63	= UpdateIndexActionKey
64	| CommandActionKey [CommandParam] String [CommandParam]
65	| InternalActionKey String
66	deriving (Eq, Ord)
67
68actionKey :: Action m -> ActionKey
69actionKey (UpdateIndexAction _) = UpdateIndexActionKey
70actionKey CommandAction { getCommonParams = c, getSubcommand = s, getParams = p } = CommandActionKey c s p
71actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActionKey s
72
73{- A queue of actions to perform (in any order) on a git repository,
74 - with lists of files to perform them on. This allows coalescing
75 - similar git commands. -}
76data Queue m = Queue
77	{ size :: Int
78	, _limit :: Int
79	, items :: M.Map ActionKey (Action m)
80	}
81
82{- A recommended maximum size for the queue, after which it should be
83 - run.
84 -
85 - 10240 is semi-arbitrary. If we assume git filenames are between 10 and
86 - 255 characters long, then the queue will build up between 100kb and
87 - 2550kb long commands. The max command line length on linux is somewhere
88 - above 20k, so this is a fairly good balance -- the queue will buffer
89 - only a few megabytes of stuff and a minimal number of commands will be
90 - run by xargs. -}
91defaultLimit :: Int
92defaultLimit = 10240
93
94{- Constructor for empty queue. -}
95new :: Maybe Int -> Queue m
96new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
97
98{- Adds an git command to the queue.
99 -
100 - Git commands with the same subcommand but different parameters are
101 - assumed to be equivilant enough to perform in any order with the same
102 - end result.
103 -}
104addCommand :: MonadIO m => [CommandParam] -> String -> [CommandParam] -> [FilePath] -> Queue m -> Repo -> m (Queue m)
105addCommand commonparams subcommand params files q repo =
106	updateQueue action different (length files) q repo
107  where
108	action = CommandAction
109		{ getCommonParams = commonparams
110		, getSubcommand = subcommand
111		, getParams = params
112		, getFiles = map File files
113		}
114
115	different (CommandAction { getSubcommand = s }) = s /= subcommand
116	different _ = True
117
118{- Adds an internal action to the queue. -}
119addInternalAction :: MonadIO m => InternalActionRunner m -> [(RawFilePath, IO Bool)] -> Queue m -> Repo -> m (Queue m)
120addInternalAction runner files q repo =
121	updateQueue action different (length files) q repo
122  where
123	action = InternalAction
124		{ getRunner = runner
125		, getInternalFiles = files
126		}
127
128	different (InternalAction { getRunner = r }) = r /= runner
129	different _ = True
130
131{- Adds an update-index streamer to the queue. -}
132addUpdateIndex :: MonadIO m => Git.UpdateIndex.Streamer -> Queue m -> Repo -> m (Queue m)
133addUpdateIndex streamer q repo =
134	updateQueue action different 1 q repo
135  where
136	-- the list is built in reverse order
137	action = UpdateIndexAction [streamer]
138
139	different (UpdateIndexAction _) = False
140	different _ = True
141
142{- Updates or adds an action in the queue. If the queue already contains a
143 - different action, it will be flushed; this is to ensure that conflicting
144 - actions, like add and rm, are run in the right order.-}
145updateQueue :: MonadIO m => Action m -> (Action m -> Bool) -> Int -> Queue m -> Repo -> m (Queue m)
146updateQueue !action different sizeincrease q repo
147	| null (filter different (M.elems (items q))) = return $ go q
148	| otherwise = go <$> flush q repo
149  where
150	go q' = newq
151	  where
152		!newq = q'
153			{ size = newsize
154			, items = newitems
155			}
156		!newsize = size q' + sizeincrease
157		!newitems = M.insertWith combineNewOld (actionKey action) action (items q')
158
159{- The new value comes first. It probably has a smaller list of files than
160 - the old value. So, the list append of the new value first is more
161 - efficient. -}
162combineNewOld :: Action m -> Action m -> Action m
163combineNewOld (CommandAction _cps1 _sc1 _ps1 fs1) (CommandAction cps2 sc2 ps2 fs2) =
164	CommandAction cps2 sc2 ps2 (fs1++fs2)
165combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) =
166	UpdateIndexAction (s1++s2)
167combineNewOld (InternalAction _r1 fs1) (InternalAction r2 fs2) =
168	InternalAction r2 (fs1++fs2)
169combineNewOld anew _aold = anew
170
171{- Merges the contents of the second queue into the first.
172 - This should only be used when the two queues are known to contain
173 - non-conflicting actions. -}
174merge :: Queue m -> Queue m -> Queue m
175merge origq newq = origq
176	{ size = size origq + size newq
177	, items = M.unionWith combineNewOld (items newq) (items origq)
178	}
179
180{- Is a queue large enough that it should be flushed? -}
181full :: Queue m -> Bool
182full (Queue cur lim  _) = cur >= lim
183
184{- Runs a queue on a git repository. -}
185flush :: MonadIO m => Queue m -> Repo -> m (Queue m)
186flush (Queue _ lim m) repo = do
187	forM_ (M.elems m) $ runAction repo
188	return $ Queue 0 lim M.empty
189
190{- Runs an Action on a list of files in a git repository.
191 -
192 - Complicated by commandline length limits.
193 -
194 - Intentionally runs the command even if the list of files is empty;
195 - this allows queueing commands that do not need a list of files. -}
196runAction :: MonadIO m => Repo -> Action m -> m ()
197runAction repo (UpdateIndexAction streamers) =
198	-- list is stored in reverse order
199	liftIO $ Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
200runAction repo action@(CommandAction {}) = liftIO $ do
201#ifndef mingw32_HOST_OS
202	let p = (proc "xargs" $ "-0":"git":toCommand gitparams)
203		{ env = gitEnv repo
204		, std_in = CreatePipe
205		}
206	withCreateProcess p (go p)
207#else
208	-- Using xargs on Windows is problematic, so just run the command
209	-- once per file (not as efficient.)
210	if null (getFiles action)
211		then void $ boolSystemEnv "git" gitparams (gitEnv repo)
212		else forM_ (getFiles action) $ \f ->
213			void $ boolSystemEnv "git" (gitparams ++ [f]) (gitEnv repo)
214#endif
215  where
216	gitparams = gitCommandLine
217		(getCommonParams action++Param (getSubcommand action):getParams action)
218		repo
219#ifndef mingw32_HOST_OS
220	go p (Just h) _ _ pid = do
221		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action
222		hClose h
223		forceSuccessProcess p pid
224	go _ _ _ _ _ = error "internal"
225#endif
226runAction repo action@(InternalAction {}) =
227	let InternalActionRunner _ runner = getRunner action
228	in runner repo (getInternalFiles action)
229