git-all-1.6.0: Main.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Main where
-- git-all.hs
--
-- by John Wiegley <johnw@newartisans.com>
--
-- A utility for determining which Git repositories need actions to be taken
-- within them.
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.Monoid
#if MIN_VERSION_shelly(1, 0, 0)
import Data.Text as T
#else
import Data.Text.Lazy as T
#endif
import Filesystem (listDirectory)
import Filesystem.Path (directory, filename)
import GHC.Conc
import Prelude hiding (FilePath)
import Shelly hiding (cmd)
import System.Console.CmdArgs
import System.Log.Logger
import System.Posix.Files
import Text.Regex.Posix
default (T.Text)
version :: String
version = "1.5.0"
copyright :: String
copyright = "2012-2013"
gitAllSummary :: String
gitAllSummary = "git-all v" ++ version ++ ", (C) John Wiegley " ++ copyright
data GitAll = GitAll { jobs :: Int
, pulls :: Bool
, untracked :: Bool
, verbose :: Bool
, debug :: Bool
, arguments :: [String] }
deriving (Data, Typeable, Show, Eq)
gitAll :: GitAll
gitAll = GitAll
{ jobs = def &= name "j" &= typ "INT"
&= help "Run INT concurrent finds at once (default: 4)"
, 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"
&= opt (T.unpack "status") }
&= summary gitAllSummary
&= program "git-all"
&= help "Fetch or get status of all Git repos under the given directories"
main :: IO ()
main = do
-- process command-line options
opts <- 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 :: IO (Chan (Maybe (FilePath, FilePath)))
_ <- forkOS $ do
parallel_ $ L.map (findDirsContaining c 0)
(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, findDirs is done and we can stop
parallel_ $ L.map (runGitCmd opts >=> putStr . unpack)
(catMaybes' dirs)
stopGlobalPool
where
runGitCmd :: GitAll -> (FilePath, FilePath) -> IO Text
runGitCmd opts = flip execStateT "" . uncurry (checkGitDirectory opts)
catMaybes' :: [Maybe a] -> [a]
catMaybes' [] = []
catMaybes' (x:xs) = case x of
Nothing -> []
Just y -> y : catMaybes' xs
-- Primary logic
type IOState = StateT Text IO
putStrM :: Text -> IOState ()
putStrM = modify . T.append
toString :: FilePath -> String
toString = unpack . toTextIgnore
fromString :: String -> FilePath
fromString = fromText . pack
checkGitDirectory :: GitAll -> FilePath -> FilePath -> IOState ()
checkGitDirectory opts gitDir workTree = do
liftIO $ debugM "git-all" $
"Scanning " ++ toString gitDir ++ " => " ++ toString workTree
url <- gitMaybe gitDir workTree "config" ["svn-remote.svn.url"]
case L.head (arguments opts) of
"fetch" ->
gitFetch gitDir workTree url
"status" -> do
mapM_ (gitPushOrPull gitDir workTree url (pulls opts))
=<< gitLocalBranches gitDir workTree
gitStatus gitDir workTree (untracked opts)
cmd -> gitCommand gitDir workTree (T.pack cmd)
-- Git command wrappers
gitStatus :: FilePath -> FilePath -> Bool -> IOState ()
gitStatus gitDir workTree showUntracked = do
changes <-
git gitDir workTree "status"
[ "--porcelain"
, append "--untracked-files="
(if showUntracked then "normal" else "no") ]
putStrM $ topTen "STATUS" workTree changes "=="
gitFetch :: FilePath -> FilePath -> Maybe Text -> IOState ()
gitFetch gitDir workTree url = do
output <-
if isNothing url
then git gitDir workTree "fetch"
["-q", "--progress", "--all", "--prune", "--tags"]
else do
out <- git gitDir workTree "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 $ T.unlines $ L.filter (not . (=~ pat) . unpack) (T.lines out)
putStrM $ topTen "FETCH" workTree output "=="
gitCommand :: FilePath -> FilePath -> Text -> IOState ()
gitCommand gitDir workTree cmd = do
output <- git gitDir workTree cmd []
putStrM $ topTen ("CMD[" <> cmd <> "]") workTree output "=="
type CommitId = Text
type BranchInfo = (CommitId, Text)
gitLocalBranches :: FilePath -> FilePath -> IOState [BranchInfo]
gitLocalBranches gitDir workTree = do
output <- git gitDir workTree "for-each-ref" ["refs/heads/"]
return $ parseGitRefs (T.lines output)
-- Each line is of the form: "<HASH> commit refs/heads/<NAME>"
where parseGitRefs [] = []
parseGitRefs (x:xs) =
(L.head words', T.drop 11 (words' !! 2)) : parseGitRefs xs
where words' = T.words x
gitPushOrPull :: FilePath -> FilePath -> Maybe Text -> Bool -> BranchInfo -> IOState ()
gitPushOrPull gitDir workTree url doPulls branch = do
remote <- gitMaybe gitDir workTree "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
then
gitMaybe gitDir workTree "rev-parse" [branchName]
else do
trunk <- gitMaybe gitDir workTree "rev-parse" ["trunk"]
case trunk of
Nothing -> gitMaybe gitDir workTree "rev-parse" ["git-svn"]
Just _ -> return trunk
when (isJust remoteSha && fst branch /= fromJust remoteSha) $ do
let logArgs = ["--no-merges", "--oneline"]
branchLabel = T.concat [toTextIgnore gitDir, "#", snd branch]
sha = fromJust remoteSha
pushLog <- git gitDir workTree "log"
(logArgs ++ [T.concat [sha, "..", fst branch], "--"])
putStrM $ topTen "NEED PUSH" (fromText branchLabel) pushLog "=="
when doPulls $ do
pullLog <- git gitDir workTree "log"
(logArgs ++ [T.concat [fst branch, "..", sha], "--"])
putStrM $ topTen "NEED PULL" (fromText branchLabel) pullLog "=="
-- Utility functions
doGit :: FilePath -> FilePath -> Text -> [Text] -> Sh Text
doGit gitDir workTree com gitArgs = do
run "git" ("--git-dir":pack (toString gitDir)
:"--work-tree":pack (toString workTree)
:com:gitArgs)
git :: FilePath -> FilePath -> Text -> [Text] -> IOState Text
git gitDir workTree com gitArgs = do
result <-
shelly $ silently $ errExit False $ do
text <- doGit gitDir workTree com gitArgs
code <- lastExitCode
if code == 0
then return $ Right text
else Left <$> lastStderr
case result of
Left err -> do
putStrM $ topTen "FAILED" (workTree <> " <= " <> gitDir) err "##"
return ""
Right text -> return text
gitMaybe :: FilePath -> FilePath -> Text -> [Text] -> IOState (Maybe Text)
gitMaybe gitDir workTree gitCmd gitArgs =
shelly $ silently $ errExit False $ do
text <- doGit gitDir workTree gitCmd gitArgs
code <- lastExitCode
if code == 0
then return . Just . L.head . T.lines $ text
else return Nothing
topTen :: Text -> FilePath -> Text -> Text -> Text
topTen _ _ "" _ = ""
topTen category pathname content marker =
T.concat $ [ "\n", marker, " ", category, " ", marker, " "
, toTextIgnore pathname, "\n"
-- , unlines (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' = T.lines content
findDirsContainingW
:: Chan (Maybe (FilePath, FilePath))
-> Int
-> FilePath
-> IO ()
findDirsContainingW c curDepth p =
catch (findDirsContaining c curDepth p)
(\e -> (e :: IOException) `seq` return ())
findDirsContaining
:: Chan (Maybe (FilePath, FilePath))
-> Int
-> FilePath
-> IO ()
findDirsContaining c curDepth p = do
status <- if curDepth == 0
then getFileStatus (toString p)
else getSymbolicLinkStatus (toString p)
when (filename p == ".git") $ do
when (isRegularFile status) $ do
t <- readFile (toString p)
when ("gitdir: " `L.isPrefixOf` t) $
writeChan c (Just (directory p </> fromText (T.strip (T.pack (L.drop 8 t))),
directory p))
when (isDirectory status) $
writeChan c (Just (p, directory p))
when (isDirectory status &&
filename p `notElem` ["CVS", ".svn", ".deps", "_darcs", "CMakeFiles"]) $ do
files <- listDirectory p
let func = findDirsContainingW c (curDepth + 1)
if curDepth == 0
then parallel_ $ L.map func files
else mapM_ func files
-- git-all.hs ends here