diff options
| -rw-r--r-- | Annex/Queue.hs | 10 | ||||
| -rw-r--r-- | Command/Watch.hs | 22 | ||||
| -rw-r--r-- | Git/HashObject.hs | 4 | ||||
| -rw-r--r-- | Git/Queue.hs | 18 | ||||
| -rw-r--r-- | Git/UnionMerge.hs | 5 |
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 . |