git-all 1.1.0 → 1.2.0
raw patch · 2 files changed
+141/−100 lines, 2 filesdep +parallel-iodep +system-fileiodep +transformersdep −monad-loops
Dependencies added: parallel-io, system-fileio, transformers, unix
Dependencies removed: monad-loops
Files
- Main.hs +138/−98
- git-all.cabal +3/−2
Main.hs view
@@ -12,139 +12,171 @@ -- A utility for determining which Git repositories need actions to be taken -- within them. -import Control.Concurrent-import Control.Concurrent.Chan-import Control.Monad-import Control.Monad.Loops+import Control.Concurrent+import Control.Concurrent.ParallelIO+import Control.Exception+import Control.Monad+import Control.Monad.Trans.State import qualified Data.List as L-import Data.Maybe-import Data.Text.Lazy as T-import Filesystem.Path (directory, filename)-import GHC.Conc-import Shelly-import System.Console.CmdArgs-import System.Environment (getArgs, withArgs)-import System.Log.Logger-import Text.Regex.Posix+import Data.Maybe+import Data.Text.Lazy as T+import Filesystem (listDirectory)+import Filesystem.Path (directory, filename)+import GHC.Conc+import Prelude hiding (FilePath, catch)+import Shelly+import System.Console.CmdArgs+import System.Environment (getArgs, withArgs)+import System.Log.Logger+import System.Posix.Files+import Text.Regex.Posix -import Prelude- hiding (FilePath, drop, replicate, lines, take, length, unlines, map) default (T.Text) -version = "1.1.0"+version :: String+version = "1.2.0"++copyright :: String copyright = "2012"++gitAllSummary :: String gitAllSummary = "git-all v" ++ version ++ ", (C) John Wiegley " ++ copyright -data GitAll = GitAll- { pulls :: Bool- , untracked :: Bool- , verbose :: Bool- , debug :: Bool- , arguments :: [String] }+data GitAll = GitAll { jobs :: Int+ , pulls :: Bool+ , untracked :: Bool+ , verbose :: Bool+ , debug :: Bool+ , arguments :: [String] } deriving (Data, Typeable, Show, Eq) gitAll :: GitAll gitAll = GitAll- { pulls = def &= name "p" &= help "Include NEED PULL sections"- , untracked = def &= name "U" &= help "Display untracked files as possible changes"- , verbose = def &= name "v" &= help "Report progress verbosely"- , debug = def &= name "D" &= help "Report debug information"+ { jobs = def &= name "j" &= typ "INT"+ &= help "Run INT concurrent finds at once (default: 2)"+ , pulls = def &= name "p"+ &= help "Include NEED PULL sections"+ , untracked = def &= name "U"+ &= help "Display untracked files as possible changes"+ , verbose = def &= name "v"+ &= help "Report progress verbosely"+ , debug = def &= name "D"+ &= help "Report debug information" , arguments = def &= args &= typ "fetch | status" } &= summary gitAllSummary &= program "git-all" &=- help "Fetch or report status of all Git repositories under the current directory"+ help "Fetch or get status of all Git repos under the given directories" main :: IO () main = do- -- use 2 cores; this utility must be linked with -threaded- GHC.Conc.setNumCapabilities 2- -- process command-line options mainArgs <- getArgs- opts <- (if L.null mainArgs then withArgs ["--help"] else id) (cmdArgs gitAll)+ opts <- withArgs (if L.null mainArgs then ["status"] else mainArgs)+ (cmdArgs gitAll) + _ <- GHC.Conc.setNumCapabilities $ case jobs opts of 0 -> 4; x -> x+ when (verbose opts) $ updateGlobalLogger "git-all" (setLevel INFO) when (debug opts) $ updateGlobalLogger "git-all" (setLevel DEBUG) -- Do a find in all directories (in sequence) in a separate operating system -- thread, so that the list of directories is accumulated while we work on -- them- c <- newChan- _ <- forkOS $ findDirectories c ((".git" ==) . filename) ["."]+ c <- newChan+ _ <- forkOS $ do+ parallel_ $ L.map (findDirs c 0 ((".git" ==) . filename))+ (let xs = L.tail (arguments opts)+ in if L.null xs+ then ["."]+ else L.map (fromText . pack) xs)+ writeChan c Nothing+ dirs <- getChanContents c -- While readChan keeps returning `Just x', call `checkGitDirectory opts- -- x'. Once it returns Nothing, findDirectories is done and we can stop- whileJust_ (readChan c) $ checkGitDirectory opts+ -- x'. Once it returns Nothing, findDirs is done and we can stop+ parallel_ $ L.map (runGitCmd opts >=> putStr . unpack)+ (catMaybes' dirs)+ stopGlobalPool + where runGitCmd :: GitAll -> FilePath -> IO Text+ runGitCmd opts = flip execStateT "" . checkGitDirectory opts++ catMaybes' :: [Maybe a] -> [a]+ catMaybes' [] = []+ catMaybes' (x:xs) = case x of+ Nothing -> []+ Just y -> y : catMaybes' xs+ -- Primary logic -checkGitDirectory :: GitAll -> FilePath -> IO ()+type IOState = StateT Text IO++putStrM :: Text -> IOState ()+putStrM = modify . T.append++toString :: FilePath -> String+toString = unpack . toTextIgnore++checkGitDirectory :: GitAll -> FilePath -> IOState () checkGitDirectory opts dir = do- debugM "git-all" $ "Scanning " ++ asText dir+ liftIO $ debugM "git-all" $ "Scanning " ++ toString dir url <- gitMaybe dir "config" ["svn-remote.svn.url"] case L.head (arguments opts) of- "fetch" ->+ "fetch" -> gitFetch dir url "status" -> do- branches <- gitLocalBranches dir- mapM_ (gitPushOrPull dir url (pulls opts)) branches-+ mapM_ (gitPushOrPull dir url (pulls opts)) =<< gitLocalBranches dir gitStatus dir (untracked opts) - unknown -> putStrLn $ "Unknown command: " ++ unknown+ unknown -> putStrM $ T.concat [ "Unknown command: ", T.pack unknown, "\n" ] -- Git command wrappers dirAsFile :: FilePath -> FilePath dirAsFile = fromText . T.init . toTextIgnore . directory -gitStatus :: FilePath -> Bool -> IO ()+gitStatus :: FilePath -> Bool -> IOState () gitStatus dir showUntracked = do changes <-- git dir "status"- [ "--porcelain"- , append "--untracked-files="- (if showUntracked then "normal" else "no") ]+ git dir "status" [ "--porcelain"+ , append "--untracked-files="+ (if showUntracked then "normal" else "no") ] - putStr $ unpack $ topTen "STATUS" (dirAsFile dir) changes "=="+ putStrM $ topTen "STATUS" (dirAsFile dir) changes "==" -gitFetch :: FilePath -> Maybe Text -> IO ()+gitFetch :: FilePath -> Maybe Text -> IOState () gitFetch dir url = do output <- if isNothing url- then- git dir "fetch" ["-q", "--progress", "--all", "--prune", "--tags"]-+ then git dir "fetch" ["-q", "--progress", "--all", "--prune", "--tags"] else do out <- git dir "svn" ["fetch"] -- jww (2012-08-06): Why doesn't =~ work on Data.Text.Lazy.Text? let pat = unpack "^(W: |This may take a while|Checked through|$)"- return $ unlines $ L.filter (not . (=~ pat) . unpack) (lines out)+ return $ T.unlines $ L.filter (not . (=~ pat) . unpack) (T.lines out) - putStr $ unpack $ topTen "FETCH" (dirAsFile dir) output "=="+ putStrM $ topTen "FETCH" (dirAsFile dir) output "==" type CommitId = Text type BranchInfo = (CommitId, Text) -gitLocalBranches :: FilePath -> IO [BranchInfo]+gitLocalBranches :: FilePath -> IOState [BranchInfo] gitLocalBranches dir = do output <- git dir "for-each-ref" ["refs/heads/"]- return $ parseGitRefs (lines output)+ return $ parseGitRefs (T.lines output) -- Each line is of the form: "<HASH> commit refs/heads/<NAME>"- where parseGitRefs (x:xs) =- (L.head words', drop 11 (words' !! 2)) : parseGitRefs xs+ where parseGitRefs [] = []+ parseGitRefs (x:xs) =+ (L.head words', T.drop 11 (words' !! 2)) : parseGitRefs xs where words' = T.words x- parseGitRefs [] = [] -gitPushOrPull :: FilePath -> Maybe Text -> Bool -> BranchInfo -> IO ()+gitPushOrPull :: FilePath -> Maybe Text -> Bool -> BranchInfo -> IOState () gitPushOrPull dir url doPulls branch = do- remote <-- gitMaybe dir "config" [T.concat ["branch.", snd branch, ".remote"]]-+ remote <- gitMaybe dir "config" [T.concat ["branch.", snd branch, ".remote"]] when (isJust remote || isJust url) $ do let branchName = T.concat [fromJust remote, "/", snd branch] remoteSha <- if isJust remote@@ -161,14 +193,14 @@ branchLabel = T.concat [toTextIgnore (dirAsFile dir), "#", snd branch] sha = fromJust remoteSha - pushLog <- git dir "log" ( logArgs- ++ [T.concat [sha, "..", fst branch], "--"])- putStr $ unpack $ topTen "NEED PUSH" (fromText branchLabel) pushLog "=="+ pushLog <- git dir "log" ( logArgs+ ++ [T.concat [sha, "..", fst branch], "--"])+ putStrM $ topTen "NEED PUSH" (fromText branchLabel) pushLog "==" when doPulls $ do- pullLog <- git dir "log" ( logArgs- ++ [T.concat [fst branch, "..", sha], "--"])- putStr $ unpack $ topTen "NEED PULL" (fromText branchLabel) pullLog "=="+ pullLog <- git dir "log" ( logArgs+ ++ [T.concat [fst branch, "..", sha], "--"])+ putStrM $ topTen "NEED PULL" (fromText branchLabel) pullLog "==" -- Utility functions @@ -178,23 +210,27 @@ let workDir = T.append "--work-tree=" (toTextIgnore (dirAsFile dir)) run "git" $ [gitDir, workDir, com] ++ gitArgs -git :: FilePath -> Text -> [Text] -> IO Text-git dir com gitArgs =- shelly $ silently $ errExit False $ do- text <- doGit dir com gitArgs- code <- lastExitCode- unless (code == 0) $ do- err <- lastStderr- liftIO $ putStr $ unpack $ topTen "FAILED" (dirAsFile dir) err "##"- return text+git :: FilePath -> Text -> [Text] -> IOState Text+git dir com gitArgs = do+ result <-+ shelly $ silently $ errExit False $ do+ text <- doGit dir com gitArgs+ code <- lastExitCode+ if code == 0+ then return $ Right text+ else return . Left =<< lastStderr+ case result of+ Left err -> do putStrM $ topTen "FAILED" (dirAsFile dir) err "##"+ return ""+ Right text -> return text -gitMaybe :: FilePath -> Text -> [Text] -> IO (Maybe Text)+gitMaybe :: FilePath -> Text -> [Text] -> IOState (Maybe Text) gitMaybe dir gitCmd gitArgs = shelly $ silently $ errExit False $ do text <- doGit dir gitCmd gitArgs code <- lastExitCode if code == 0- then return . Just . L.head . lines $ text+ then return . Just . L.head . T.lines $ text else return Nothing topTen :: Text -> FilePath -> Text -> Text -> Text@@ -203,30 +239,34 @@ T.concat $ [ "\n", marker, " ", category, " ", marker, " " , toTextIgnore pathname, "\n" -- , unlines (L.take 10 ls)- , unlines (L.map (take 80) (L.take 10 ls')) ]+ , T.unlines (L.map (T.take 80) (L.take 10 ls')) ] ++ (let len = L.length (L.drop 10 ls') in case len of 0 -> [] _ -> ["... (and " , pack (show len) , " more)\n"])- where ls' = lines content+ where ls' = T.lines content -findDirectories :: Chan (Maybe FilePath) -> (FilePath -> Bool) -> [FilePath] -> IO ()-findDirectories c findPred dirs = do- -- This is a bit dense, so here's the breakdown:- --- -- 1. Given a list of `dirs', call test_d to find which are really there- -- 2. Bind the function after >>= to this list, which maps over each- -- directory, calling findFold on each one- -- 3. The fold calls writeChan for each directory matching our predicate- -- 4. When it's all done, write Nothing to the channel to let the caller- -- know we're all done.+findDirsW :: Chan (Maybe FilePath) -> Int -> (FilePath -> Bool) -> FilePath+ -> IO ()+findDirsW c curDepth findPred p =+ catch (findDirs c curDepth findPred p)+ (\e -> (e :: IOException) `seq` return ()) - shelly $ filterM test_d dirs >>=- mapM_ (findFold (\_ p -> when (findPred p) $- liftIO . writeChan c . Just $ p) ())- writeChan c Nothing+findDirs :: Chan (Maybe FilePath) -> Int -> (FilePath -> Bool) -> FilePath+ -> IO ()+findDirs c curDepth findPred p = do+ status <- if curDepth == 0+ then getFileStatus (toString p)+ else getSymbolicLinkStatus (toString p) -asText :: FilePath -> String-asText = unpack . toTextIgnore+ when (isDirectory status) $+ if findPred p+ then writeChan c (Just p)+ else do+ files <- listDirectory p+ let func = findDirsW c (curDepth + 1) findPred+ if curDepth == 0+ then parallel_ $ L.map func files+ else mapM_ func files -- git-all.hs ends here
git-all.cabal view
@@ -1,6 +1,6 @@ Name: git-all -Version: 1.1.0+Version: 1.2.0 Synopsis: Determine which Git repositories need actions to be taken Description: A utility for determining which Git repositories need actions to be@@ -22,7 +22,8 @@ Ghc-options: -threaded Build-depends: base >= 4 && < 5, shelly, cmdargs, hslogger, regex-posix,- system-filepath, text, monad-loops+ system-filepath, text, transformers, parallel-io, unix,+ system-fileio Source-repository head type: git