make watch use the queue

May not work. Certianly needs to flush the queue from time to time
when only symlink changes are being made.

5 files changed, 35 insertions, 24 deletions

diff --git a/Annex/Queue.hs b/Annex/Queue.hs
index 9f2ad6791..a7d4e153b 100644
--- a/Annex/Queue.hs
+++ b/Annex/Queue.hs
@@ -1,12 +1,13 @@
 {- git-annex command queue
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011, 2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 module Annex.Queue (
 	addCommand,
+	addUpdateIndex,
 	flush,
 	flushWhenFull
 ) where
@@ -14,6 +15,7 @@ module Annex.Queue (
 import Common.Annex
 import Annex hiding (new)
 import qualified Git.Queue
+import qualified Git.UpdateIndex
 import Config
 
 {- Adds a git command to the queue. -}
@@ -22,6 +24,12 @@ addCommand command params files = do
 	q <- get
 	store =<< inRepo (Git.Queue.addCommand command params files q)
 
+{- Adds an update-index stream to the queue. -}
+addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
+addUpdateIndex streamer = do
+	q <- get
+	store =<< inRepo (Git.Queue.addUpdateIndex streamer q)
+
 {- Runs the queue if it is full. Should be called periodically. -}
 flushWhenFull :: Annex ()
 flushWhenFull = do
diff --git a/Command/Watch.hs b/Command/Watch.hs
index 046fca7d1..4447d4ffe 100644
--- a/Command/Watch.hs
+++ b/Command/Watch.hs
@@ -15,8 +15,8 @@ import Command
 import Utility.Inotify
 import Utility.ThreadLock
 import qualified Annex
+import qualified Annex.Queue
 import qualified Command.Add
-import qualified Git
 import qualified Git.Command
 import qualified Git.UpdateIndex
 import Git.HashObject
@@ -99,7 +99,7 @@ onAdd file = do
 		go Nothing = showEndFail
 		go (Just key) = do
 			link <- Command.Add.link file key True
-			inRepo $ stageSymlink file link
+			stageSymlink file link
 			showEndOk
 
 {- A symlink might be an arbitrary symlink, which is just added.
@@ -119,7 +119,7 @@ onAddSymlink file = go =<< Backend.lookupFile file
 					liftIO $ createSymbolicLink link file
 					addlink link
 				)
-		addlink link = inRepo $ stageSymlink file link
+		addlink link = stageSymlink file link
 
 {- The file could reappear at any time, so --cached is used, to only delete
  - it from the index. -}
@@ -139,12 +139,10 @@ onErr = warning
 
 {- Adds a symlink to the index, without ever accessing the actual symlink
  - on disk. -}
-stageSymlink :: FilePath -> String -> Git.Repo -> IO ()
-stageSymlink file linktext repo = Git.UpdateIndex.stream_update_index repo [stage]
-	where
-		stage streamer = do
-			line <- Git.UpdateIndex.update_index_line
-				<$> (hashObject repo BlobObject linktext)
-				<*> pure SymlinkBlob
-				<*> toTopFilePath file repo
-			streamer line
+stageSymlink :: FilePath -> String -> Annex ()
+stageSymlink file linktext = do
+	line <- Git.UpdateIndex.update_index_line
+		<$> inRepo (hashObject BlobObject linktext)
+		<*> pure SymlinkBlob
+		<*> inRepo (toTopFilePath file)
+	Annex.Queue.addUpdateIndex $ \streamer -> streamer line
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
index b052413fd..9f37de5ba 100644
--- a/Git/HashObject.hs
+++ b/Git/HashObject.hs
@@ -36,8 +36,8 @@ hashFile h file = CoProcess.query h send receive
 		receive from = getSha "hash-object" $ hGetLine from
 
 {- Injects some content into git, returning its Sha. -}
-hashObject :: Repo -> ObjectType -> String -> IO Sha
-hashObject repo objtype content = getSha subcmd $ do
+hashObject :: ObjectType -> String -> Repo -> IO Sha
+hashObject objtype content repo = getSha subcmd $ do
 	(h, s) <- pipeWriteRead (map Param params) content repo
 	length s `seq` do
 		forceSuccess h
diff --git a/Git/Queue.hs b/Git/Queue.hs
index 5870bf866..f2312cfaa 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -77,13 +77,11 @@ defaultLimit = 10240
 new :: Maybe Int -> Queue
 new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
 
-{- Adds a command 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. 
+{- Adds an git command to the queue.
  -
- - Actions with the same subcommand but different parameters are
- - roughly equivilant; assumed equivilant enough to perform in any order
- - with the same result.
+ - Git commands with the same subcommand but different parameters are
+ - assumed to be equivilant enough to perform in any order with the same
+ - result.
  -}
 addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
 addCommand subcommand params files q repo =
@@ -100,6 +98,11 @@ addCommand subcommand params files q repo =
 		different (CommandAction { getSubcommand = s }) = s /= subcommand
 		different _ = True
 
+{- Adds an update-index streamer to the queue. 
+ -
+ - Note that this does not increase the queue size, because data is
+ - streamed into update-index, so command-line length limits are not
+ - involved. -}
 addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
 addUpdateIndex streamer q repo =
 	updateQueue action different 0 q repo
@@ -147,7 +150,8 @@ flush (Queue _ lim m) repo = do
  - 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 -> IO ()
-runAction _repo _action@(UpdateIndexAction {}) = error "TODO"
+runAction repo (UpdateIndexAction streamers) =
+	Git.UpdateIndex.stream_update_index repo streamers
 runAction repo action@(CommandAction {}) =
 	pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
 	where
diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs
index f65b59c53..d38bdfe22 100644
--- a/Git/UnionMerge.hs
+++ b/Git/UnionMerge.hs
@@ -74,8 +74,9 @@ mergeFile :: String -> FilePath -> CatFileHandle -> Repo -> IO (Maybe String)
 mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
 	[] -> return Nothing
 	(sha:[]) -> use sha
-	shas -> use =<< either return (hashObject repo BlobObject . unlines) =<<
-		calcMerge . zip shas <$> mapM getcontents shas
+	shas -> use
+		=<< either return (\s -> hashObject BlobObject (unlines s) repo)
+		=<< calcMerge . zip shas <$> mapM getcontents shas
 	where
 		[_colonmode, _bmode, asha, bsha, _status] = words info
 		getcontents s = map L.unpack . L.lines .