summaryrefslogtreecommitdiff
path: root/GitQueue.hs
blob: 2d44a8f108dd3eefc2451eaf62fccead7ee2fefd (plain)
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
{- git repository command queue
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module GitQueue (
	Queue,
	empty,
	add,
	run
) where

import qualified Data.Map as M
import System.IO
import System.Cmd.Utils
import Data.String.Utils
import Control.Monad (unless)

import qualified GitRepo as Git

{- 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 :: [String]
	} deriving (Show, Eq, Ord)

{- 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. -}
type Queue = M.Map Action [FilePath]

{- Constructor for empty queue. -}
empty :: Queue
empty = M.empty

{- Adds an action to a queue. -}
add :: Queue -> String -> [String] -> FilePath -> Queue
add queue subcommand params file = M.insertWith (++) action [file] queue
	where
		action = Action subcommand params

{- Runs a queue on a git repository. -}
run :: Git.Repo -> Queue -> IO ()
run repo queue = do
	_ <- mapM (\(k, v) -> runAction repo k v) $ M.toList queue
	return ()

{- Runs an Action on a list of files in a git repository.
 -
 - Complicated by commandline length limits. -}
runAction :: Git.Repo -> Action -> [FilePath] -> IO ()
runAction repo action files = do
	unless (null files) runxargs
	where
		runxargs = pOpen WriteToPipe "xargs" ("-0":gitcmd) feedxargs
		gitcmd = ["git"] ++ Git.gitCommandLine repo
			(getSubcommand action:getParams action)
		feedxargs h = hPutStr h $ join "\0" files