1{- git repository command queue 2 - 3 - Copyright 2010-2021 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE CPP, BangPatterns #-} 9 10module Git.Queue ( 11 Queue, 12 new, 13 addCommand, 14 addUpdateIndex, 15 addInternalAction, 16 InternalActionRunner(..), 17 size, 18 full, 19 flush, 20 merge, 21) where 22 23import Utility.SafeCommand 24import Common 25import Git 26import Git.Command 27import qualified Git.UpdateIndex 28 29import qualified Data.Map.Strict as M 30import Control.Monad.IO.Class 31 32{- Queable actions that can be performed in a git repository. -} 33data Action m 34 {- Updating the index file, using a list of streamers that can 35 - be added to as the queue grows. -} 36 = UpdateIndexAction [Git.UpdateIndex.Streamer] -- in reverse order 37 {- A git command to run, on a list of files that can be added to 38 - as the queue grows. -} 39 | CommandAction 40 { getCommonParams :: [CommandParam] 41 -- ^ parameters that come before the git subcommand 42 -- (in addition to the Repo's gitGlobalOpts. 43 , getSubcommand :: String 44 , getParams :: [CommandParam] 45 -- ^ parameters that come after the git subcommand 46 , getFiles :: [CommandParam] 47 } 48 {- An internal action to run, on a list of files that can be added 49 - to as the queue grows. -} 50 | InternalAction 51 { getRunner :: InternalActionRunner m 52 , getInternalFiles :: [(RawFilePath, IO Bool)] 53 } 54 55{- The String must be unique for each internal action. -} 56data InternalActionRunner m = InternalActionRunner String (Repo -> [(RawFilePath, IO Bool)] -> m ()) 57 58instance Eq (InternalActionRunner m) where 59 InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2 60 61{- A key that can uniquely represent an action in a Map. -} 62data ActionKey 63 = UpdateIndexActionKey 64 | CommandActionKey [CommandParam] String [CommandParam] 65 | InternalActionKey String 66 deriving (Eq, Ord) 67 68actionKey :: Action m -> ActionKey 69actionKey (UpdateIndexAction _) = UpdateIndexActionKey 70actionKey CommandAction { getCommonParams = c, getSubcommand = s, getParams = p } = CommandActionKey c s p 71actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActionKey s 72 73{- A queue of actions to perform (in any order) on a git repository, 74 - with lists of files to perform them on. This allows coalescing 75 - similar git commands. -} 76data Queue m = Queue 77 { size :: Int 78 , _limit :: Int 79 , items :: M.Map ActionKey (Action m) 80 } 81 82{- A recommended maximum size for the queue, after which it should be 83 - run. 84 - 85 - 10240 is semi-arbitrary. If we assume git filenames are between 10 and 86 - 255 characters long, then the queue will build up between 100kb and 87 - 2550kb long commands. The max command line length on linux is somewhere 88 - above 20k, so this is a fairly good balance -- the queue will buffer 89 - only a few megabytes of stuff and a minimal number of commands will be 90 - run by xargs. -} 91defaultLimit :: Int 92defaultLimit = 10240 93 94{- Constructor for empty queue. -} 95new :: Maybe Int -> Queue m 96new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty 97 98{- Adds an git command to the queue. 99 - 100 - Git commands with the same subcommand but different parameters are 101 - assumed to be equivilant enough to perform in any order with the same 102 - end result. 103 -} 104addCommand :: MonadIO m => [CommandParam] -> String -> [CommandParam] -> [FilePath] -> Queue m -> Repo -> m (Queue m) 105addCommand commonparams subcommand params files q repo = 106 updateQueue action different (length files) q repo 107 where 108 action = CommandAction 109 { getCommonParams = commonparams 110 , getSubcommand = subcommand 111 , getParams = params 112 , getFiles = map File files 113 } 114 115 different (CommandAction { getSubcommand = s }) = s /= subcommand 116 different _ = True 117 118{- Adds an internal action to the queue. -} 119addInternalAction :: MonadIO m => InternalActionRunner m -> [(RawFilePath, IO Bool)] -> Queue m -> Repo -> m (Queue m) 120addInternalAction runner files q repo = 121 updateQueue action different (length files) q repo 122 where 123 action = InternalAction 124 { getRunner = runner 125 , getInternalFiles = files 126 } 127 128 different (InternalAction { getRunner = r }) = r /= runner 129 different _ = True 130 131{- Adds an update-index streamer to the queue. -} 132addUpdateIndex :: MonadIO m => Git.UpdateIndex.Streamer -> Queue m -> Repo -> m (Queue m) 133addUpdateIndex streamer q repo = 134 updateQueue action different 1 q repo 135 where 136 -- the list is built in reverse order 137 action = UpdateIndexAction [streamer] 138 139 different (UpdateIndexAction _) = False 140 different _ = True 141 142{- Updates or adds an action in the queue. If the queue already contains a 143 - different action, it will be flushed; this is to ensure that conflicting 144 - actions, like add and rm, are run in the right order.-} 145updateQueue :: MonadIO m => Action m -> (Action m -> Bool) -> Int -> Queue m -> Repo -> m (Queue m) 146updateQueue !action different sizeincrease q repo 147 | null (filter different (M.elems (items q))) = return $ go q 148 | otherwise = go <$> flush q repo 149 where 150 go q' = newq 151 where 152 !newq = q' 153 { size = newsize 154 , items = newitems 155 } 156 !newsize = size q' + sizeincrease 157 !newitems = M.insertWith combineNewOld (actionKey action) action (items q') 158 159{- The new value comes first. It probably has a smaller list of files than 160 - the old value. So, the list append of the new value first is more 161 - efficient. -} 162combineNewOld :: Action m -> Action m -> Action m 163combineNewOld (CommandAction _cps1 _sc1 _ps1 fs1) (CommandAction cps2 sc2 ps2 fs2) = 164 CommandAction cps2 sc2 ps2 (fs1++fs2) 165combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) = 166 UpdateIndexAction (s1++s2) 167combineNewOld (InternalAction _r1 fs1) (InternalAction r2 fs2) = 168 InternalAction r2 (fs1++fs2) 169combineNewOld anew _aold = anew 170 171{- Merges the contents of the second queue into the first. 172 - This should only be used when the two queues are known to contain 173 - non-conflicting actions. -} 174merge :: Queue m -> Queue m -> Queue m 175merge origq newq = origq 176 { size = size origq + size newq 177 , items = M.unionWith combineNewOld (items newq) (items origq) 178 } 179 180{- Is a queue large enough that it should be flushed? -} 181full :: Queue m -> Bool 182full (Queue cur lim _) = cur >= lim 183 184{- Runs a queue on a git repository. -} 185flush :: MonadIO m => Queue m -> Repo -> m (Queue m) 186flush (Queue _ lim m) repo = do 187 forM_ (M.elems m) $ runAction repo 188 return $ Queue 0 lim M.empty 189 190{- Runs an Action on a list of files in a git repository. 191 - 192 - Complicated by commandline length limits. 193 - 194 - Intentionally runs the command even if the list of files is empty; 195 - this allows queueing commands that do not need a list of files. -} 196runAction :: MonadIO m => Repo -> Action m -> m () 197runAction repo (UpdateIndexAction streamers) = 198 -- list is stored in reverse order 199 liftIO $ Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers 200runAction repo action@(CommandAction {}) = liftIO $ do 201#ifndef mingw32_HOST_OS 202 let p = (proc "xargs" $ "-0":"git":toCommand gitparams) 203 { env = gitEnv repo 204 , std_in = CreatePipe 205 } 206 withCreateProcess p (go p) 207#else 208 -- Using xargs on Windows is problematic, so just run the command 209 -- once per file (not as efficient.) 210 if null (getFiles action) 211 then void $ boolSystemEnv "git" gitparams (gitEnv repo) 212 else forM_ (getFiles action) $ \f -> 213 void $ boolSystemEnv "git" (gitparams ++ [f]) (gitEnv repo) 214#endif 215 where 216 gitparams = gitCommandLine 217 (getCommonParams action++Param (getSubcommand action):getParams action) 218 repo 219#ifndef mingw32_HOST_OS 220 go p (Just h) _ _ pid = do 221 hPutStr h $ intercalate "\0" $ toCommand $ getFiles action 222 hClose h 223 forceSuccessProcess p pid 224 go _ _ _ _ _ = error "internal" 225#endif 226runAction repo action@(InternalAction {}) = 227 let InternalActionRunner _ runner = getRunner action 228 in runner repo (getInternalFiles action) 229