summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex/Queue.hs8
-rw-r--r--Command/Add.hs2
-rw-r--r--Command/Fix.hs2
-rw-r--r--Command/FromKey.hs2
-rw-r--r--Command/Fsck.hs2
-rw-r--r--Command/Lock.hs2
-rw-r--r--Git/Queue.hs111
-rw-r--r--Upgrade/V1.hs8
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