diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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: " commit refs/heads/" - 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 diff --git a/git-all.cabal b/git-all.cabal --- a/git-all.cabal +++ b/git-all.cabal @@ -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