135d75f2b9
I wanted to use M.insertWith' (\_ l -> file:l) action [] m , but the order of the parameters and which to ignore is not clear, and seems unsafe to rely on.
89 lines
2.6 KiB
Haskell
89 lines
2.6 KiB
Haskell
{- git repository command queue
|
|
-
|
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module GitQueue (
|
|
Queue,
|
|
empty,
|
|
add,
|
|
size,
|
|
full,
|
|
flush
|
|
) where
|
|
|
|
import qualified Data.Map as M
|
|
import System.IO
|
|
import System.Cmd.Utils
|
|
import Data.String.Utils
|
|
import Control.Monad (unless, forM_)
|
|
import Utility
|
|
|
|
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 {
|
|
getSubcommand :: String,
|
|
getParams :: [CommandParam]
|
|
} 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. -}
|
|
data Queue = Queue Int (M.Map Action [FilePath])
|
|
deriving (Show, Eq)
|
|
|
|
{- A recommended maximum size for the queue, after which it should be
|
|
- run.
|
|
-
|
|
- 10240 is semi-arbitrary. If we assume git filenames are between 10 and
|
|
- 255 characters long, then the queue will build up between 100kb and
|
|
- 2550kb long commands. The max command line length on linux is somewhere
|
|
- above 20k, so this is a fairly good balance -- the queue will buffer
|
|
- only a few megabytes of stuff and a minimal number of commands will be
|
|
- run by xargs. -}
|
|
maxSize :: Int
|
|
maxSize = 10240
|
|
|
|
{- Constructor for empty queue. -}
|
|
empty :: Queue
|
|
empty = Queue 0 M.empty
|
|
|
|
{- Adds an action to a queue. -}
|
|
add :: Queue -> String -> [CommandParam] -> FilePath -> Queue
|
|
add (Queue n m) subcommand params file = Queue (n + 1) m'
|
|
where
|
|
action = Action subcommand params
|
|
-- There are probably few items in the map, but there
|
|
-- can be a lot of files per item. So, optimise adding
|
|
-- files.
|
|
m' = M.insertWith' const action files m
|
|
files = file:(M.findWithDefault [] action m)
|
|
|
|
{- Number of items in a queue. -}
|
|
size :: Queue -> Int
|
|
size (Queue n _) = n
|
|
|
|
{- Is a queue large enough that it should be flushed? -}
|
|
full :: Queue -> Bool
|
|
full (Queue n _) = n > maxSize
|
|
|
|
{- Runs a queue on a git repository. -}
|
|
flush :: Git.Repo -> Queue -> IO Queue
|
|
flush repo (Queue _ m) = do
|
|
forM_ (M.toList m) $ uncurry $ runAction repo
|
|
return empty
|
|
|
|
{- 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 = unless (null files) runxargs
|
|
where
|
|
runxargs = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
|
|
params = toCommand $ Git.gitCommandLine repo
|
|
(Param (getSubcommand action):getParams action)
|
|
feedxargs h = hPutStr h $ join "\0" files
|