add git queue to Annex monad

not used anywhere just yet..

4 files changed, 112 insertions, 7 deletions

diff --git a/Annex.hs b/Annex.hs
index d021f936e..1963d19c6 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -11,25 +11,28 @@ module Annex (
 	flagIsSet,
 	flagChange,
 	flagGet,
-	Flag(..)
+	Flag(..),
+	queue,
+	queueGet
 ) where
 
 import Control.Monad.State
 import qualified Data.Map as M
 
 import qualified GitRepo as Git
+import qualified GitQueue
 import Types
 import qualified TypeInternals as Internals
 
-{- Create and returns an Annex state object for the specified git repo.
- -}
+{- Create and returns an Annex state object for the specified git repo. -}
 new :: Git.Repo -> [Backend] -> IO AnnexState
 new gitrepo allbackends = do
 	let s = Internals.AnnexState {
 		Internals.repo = gitrepo,
 		Internals.backends = [],
 		Internals.supportedBackends = allbackends,
-		Internals.flags = M.empty
+		Internals.flags = M.empty,
+		Internals.repoqueue = GitQueue.empty
 	}
 	(_,s') <- Annex.run s (prep gitrepo)
 	return s'
@@ -39,46 +42,73 @@ new gitrepo allbackends = do
 			gitrepo' <- liftIO $ Git.configRead gitrepo
 			Annex.gitRepoChange gitrepo'
 
--- performs an action in the Annex monad
+{- performs an action in the Annex monad -}
 run state action = runStateT (action) state
 
--- Annex monad state accessors
+{- Returns the git repository being acted on -}
 gitRepo :: Annex Git.Repo
 gitRepo = do
 	state <- get
 	return (Internals.repo state)
+
+{- Changes the git repository being acted on. -}
 gitRepoChange :: Git.Repo -> Annex ()
 gitRepoChange r = do
 	state <- get
 	put state { Internals.repo = r }
 	return ()
+
+{- Returns the backends being used. -}
 backends :: Annex [Backend]
 backends = do
 	state <- get
 	return (Internals.backends state)
+
+{- Sets the backends to use. -}
 backendsChange :: [Backend] -> Annex ()
 backendsChange b = do
 	state <- get
 	put state { Internals.backends = b }
 	return ()
+
+{- Returns the full list of supported backends. -}
 supportedBackends :: Annex [Backend]
 supportedBackends = do
 	state <- get
 	return (Internals.supportedBackends state)
+
+{- Return True if a Bool flag is set. -}
 flagIsSet :: FlagName -> Annex Bool
 flagIsSet name = do
 	state <- get
 	case (M.lookup name $ Internals.flags state) of
 		Just (FlagBool True) -> return True
 		_ -> return False 
+
+{- Sets the value of a flag. -}
 flagChange :: FlagName -> Flag -> Annex ()
 flagChange name val = do
 	state <- get
 	put state { Internals.flags = M.insert name val $ Internals.flags state }
 	return ()
+
+{- Gets the value of a String flag (or "" if there is no such String flag) -}
 flagGet :: FlagName -> Annex String
 flagGet name = do
 	state <- get
 	case (M.lookup name $ Internals.flags state) of
 		Just (FlagString s) -> return s
 		_ -> return ""
+
+{- Adds a git command to the queue. -}
+queue :: String -> [String] -> FilePath -> Annex ()
+queue subcommand params file = do
+	state <- get
+	let q = Internals.repoqueue state
+	put state { Internals.repoqueue = GitQueue.add q subcommand params file }
+
+{- Returns the queue. -}
+queueGet :: Annex GitQueue.Queue
+queueGet = do
+	state <- get
+	return (Internals.repoqueue state)
diff --git a/Core.hs b/Core.hs
index 881b668e0..4c7c9205e 100644
--- a/Core.hs
+++ b/Core.hs
@@ -14,6 +14,7 @@ import Locations
 import LocationLog
 import UUID
 import qualified GitRepo as Git
+import qualified GitQueue
 import qualified Annex
 import Utility
 			
@@ -30,6 +31,14 @@ shutdown :: Annex Bool
 shutdown = do
 	g <- Annex.gitRepo
 
+	-- Runs all queued git commands.
+	q <- Annex.queueGet
+	if (q == GitQueue.empty)
+		then return ()
+		else do
+			liftIO $ putStrLn "Recording state in git..."
+			liftIO $ GitQueue.run g q
+
 	liftIO $ Git.run g ["add", gitStateDir g]
 
 	-- clean up any files left in the temp directory, but leave
diff --git a/GitQueue.hs b/GitQueue.hs
new file mode 100644
index 000000000..b7210ccb5
--- /dev/null
+++ b/GitQueue.hs
@@ -0,0 +1,64 @@
+{- git repository command queues
+ -}
+
+module GitQueue (
+	Queue,
+	empty,
+	add,
+	run
+) where
+
+import qualified Data.Map as M
+
+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 {
+		subcommand :: String,
+		params :: [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
+	xargs [] 0 files
+	where
+		arg_max = 2048 -- TODO get better ARG_MAX
+		maxlen = arg_max - cmdlen
+		c = (subcommand action):(params action)
+		cmdlen = (length "git") + 
+			(foldl (\a b -> a + b + 1) 1 $ map length c)
+		xargs collect _ [] = exec collect
+		xargs collect len (f:fs) = do
+			let len' = len + 1 + length f
+			if (len' >= maxlen)
+				then do
+					exec collect
+					xargs [f] (length f) fs
+				else xargs (f:collect) len' fs
+		exec [] = return ()
+		exec fs = Git.run repo $ c ++ fs
diff --git a/TypeInternals.hs b/TypeInternals.hs
index 188f5e534..d4404fd39 100644
--- a/TypeInternals.hs
+++ b/TypeInternals.hs
@@ -10,6 +10,7 @@ import Data.String.Utils
 import qualified Data.Map as M
 
 import qualified GitRepo as Git
+import qualified GitQueue
 
 -- command-line flags
 type FlagName = String
@@ -24,7 +25,8 @@ data AnnexState = AnnexState {
 	repo :: Git.Repo,
 	backends :: [Backend],
 	supportedBackends :: [Backend],
-	flags :: M.Map FlagName Flag
+	flags :: M.Map FlagName Flag,
+	repoqueue :: GitQueue.Queue
 } deriving (Show)
 
 -- git-annex's monad