diff options
| -rw-r--r-- | Annex/Queue.hs | 8 | ||||
| -rw-r--r-- | Command/Add.hs | 2 | ||||
| -rw-r--r-- | Command/Fix.hs | 2 | ||||
| -rw-r--r-- | Command/FromKey.hs | 2 | ||||
| -rw-r--r-- | Command/Fsck.hs | 2 | ||||
| -rw-r--r-- | Command/Lock.hs | 2 | ||||
| -rw-r--r-- | Git/Queue.hs | 111 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 8 |
8 files changed, 94 insertions, 43 deletions
diff --git a/Annex/Queue.hs b/Annex/Queue.hs index d4a2c592e..9f2ad6791 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -6,7 +6,7 @@ -} module Annex.Queue ( - add, + addCommand, flush, flushWhenFull ) where @@ -17,10 +17,10 @@ import qualified Git.Queue import Config {- Adds a git command to the queue. -} -add :: String -> [CommandParam] -> [FilePath] -> Annex () -add command params files = do +addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () +addCommand command params files = do q <- get - store =<< inRepo (Git.Queue.add q command params files) + store =<< inRepo (Git.Queue.addCommand command params files q) {- Runs the queue if it is full. Should be called periodically. -} flushWhenFull :: Annex () diff --git a/Command/Add.hs b/Command/Add.hs index ea0f85033..3f39f8713 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -121,5 +121,5 @@ cleanup file key hascontent = do ( return [Param "-f"] , return [] ) - Annex.Queue.add "add" (params++[Param "--"]) [file] + Annex.Queue.addCommand "add" (params++[Param "--"]) [file] return True diff --git a/Command/Fix.hs b/Command/Fix.hs index c4f981381..227e08cd2 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -36,5 +36,5 @@ perform file link = do cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.Queue.add "add" [Param "--force", Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] return True diff --git a/Command/FromKey.hs b/Command/FromKey.hs index ec194e06e..f7841c977 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -39,5 +39,5 @@ perform key file = do cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.Queue.add "add" [Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--"] [file] return True diff --git a/Command/Fsck.hs b/Command/Fsck.hs index ae21acf8a..1fc656207 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -155,7 +155,7 @@ fixLink key file = do liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ removeFile file liftIO $ createSymbolicLink want file - Annex.Queue.add "add" [Param "--force", Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] return True {- Checks that the location log reflects the current status of the key, diff --git a/Command/Lock.hs b/Command/Lock.hs index ab97b14bc..8aadf3f59 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -24,5 +24,5 @@ start file = do perform :: FilePath -> CommandPerform perform file = do - Annex.Queue.add "checkout" [Param "--"] [file] + Annex.Queue.addCommand "checkout" [Param "--"] [file] next $ return True -- no cleanup needed diff --git a/Git/Queue.hs b/Git/Queue.hs index 956e9adb1..5870bf866 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -10,7 +10,8 @@ module Git.Queue ( Queue, new, - add, + addCommand, + addUpdateIndex, size, full, flush, @@ -25,19 +26,31 @@ import Utility.SafeCommand import Common import Git import Git.Command +import qualified Git.UpdateIndex + +{- Queable actions that can be performed in a git repository. + -} +data Action + {- Updating the index file, using a list of streamers that can + - be added to as the queue grows. -} + = UpdateIndexAction + { getStreamers :: [Git.UpdateIndex.Streamer] + } + {- A git command to run, on a list of files that can be added to + - as the queue grows. -} + | CommandAction + { getSubcommand :: String + , getParams :: [CommandParam] + , getFiles :: [FilePath] + } -{- 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 :: [CommandParam] - } deriving (Show, Eq, Ord) +{- A key that can uniquely represent an action in a Map. -} +data ActionKey = UpdateIndexActionKey | CommandActionKey String + deriving (Eq, Ord) -{- Compares two actions by subcommand. -} -(===) :: Action -> Action -> Bool -a === b = getSubcommand a == getSubcommand b -(/==) :: Action -> Action -> Bool -a /== b = not $ a === b +actionKey :: Action -> ActionKey +actionKey (UpdateIndexAction _) = UpdateIndexActionKey +actionKey CommandAction { getSubcommand = s } = CommandActionKey s {- A queue of actions to perform (in any order) on a git repository, - with lists of files to perform them on. This allows coalescing @@ -45,9 +58,8 @@ a /== b = not $ a === b data Queue = Queue { size :: Int , _limit :: Int - , _items :: M.Map Action [FilePath] + , items :: M.Map ActionKey Action } - deriving (Show, Eq) {- A recommended maximum size for the queue, after which it should be - run. @@ -65,20 +77,58 @@ defaultLimit = 10240 new :: Maybe Int -> Queue new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty -{- Adds an action to a queue. If the queue already contains a different +{- 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. -} -add :: Queue -> String -> [CommandParam] -> [FilePath] -> Repo -> IO Queue -add q@(Queue _ _ m) subcommand params files repo - | null (filter (/== action) (M.keys m)) = go q - | otherwise = go =<< flush q repo + - like add and rm, are run in the right order. + - + - Actions with the same subcommand but different parameters are + - roughly equivilant; assumed 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 = + updateQueue action different (length newfiles) q repo + where + key = actionKey action + action = CommandAction + { getSubcommand = subcommand + , getParams = params + , getFiles = newfiles + } + newfiles = files ++ maybe [] getFiles (M.lookup key $ items q) + + different (CommandAction { getSubcommand = s }) = s /= subcommand + different _ = True + +addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue +addUpdateIndex streamer q repo = + updateQueue action different 0 q repo + where + key = actionKey action + -- streamer is added to the end of the list, since + -- order does matter for update-index input + action = UpdateIndexAction $ streamers ++ [streamer] + streamers = maybe [] getStreamers $ M.lookup key $ items q + + different (UpdateIndexAction _) = False + different _ = True + +{- Updates or adds an action in the 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.-} +updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue +updateQueue action different sizeincrease q repo + | null (filter different (M.elems (items q))) = return $ go q + | otherwise = go <$> flush q repo where - action = Action subcommand params - go (Queue cur lim m') = - return $ Queue (cur + 1) lim $ - M.insertWith' const action fs m' - where - !fs = files ++ M.findWithDefault [] action m' + go q' = newq + where + !newq = q' + { size = newsize + , items = newitems + } + !newsize = size q' + sizeincrease + !newitems = M.insertWith' const (actionKey action) action (items q') {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool @@ -87,7 +137,7 @@ full (Queue cur lim _) = cur > lim {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue flush (Queue _ lim m) repo = do - forM_ (M.toList m) $ uncurry $ runAction repo + forM_ (M.elems m) $ runAction repo return $ Queue 0 lim M.empty {- Runs an Action on a list of files in a git repository. @@ -96,12 +146,13 @@ 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 -> [FilePath] -> IO () -runAction repo action files = +runAction :: Repo -> Action -> IO () +runAction _repo _action@(UpdateIndexAction {}) = error "TODO" +runAction repo action@(CommandAction {}) = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs where params = toCommand $ gitCommandLine (Param (getSubcommand action):getParams action) repo feedxargs h = do fileEncoding h - hPutStr h $ join "\0" files + hPutStr h $ join "\0" $ getFiles action diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 280742f06..31c0210c0 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -94,7 +94,7 @@ updateSymlinks = do link <- calcGitLink f k liftIO $ removeFile f liftIO $ createSymbolicLink link f - Annex.Queue.add "add" [Param "--"] [f] + Annex.Queue.addCommand "add" [Param "--"] [f] moveLocationLogs :: Annex () moveLocationLogs = do @@ -121,9 +121,9 @@ moveLocationLogs = do old <- liftIO $ readLog1 f new <- liftIO $ readLog1 dest liftIO $ writeLog1 dest (old++new) - Annex.Queue.add "add" [Param "--"] [dest] - Annex.Queue.add "add" [Param "--"] [f] - Annex.Queue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f] + Annex.Queue.addCommand "add" [Param "--"] [dest] + Annex.Queue.addCommand "add" [Param "--"] [f] + Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f] oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key l |