diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2003-2009, John Wiegley. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +- Neither the name of New Artisans LLC nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,226 @@ +#!/usr/bin/env runhaskell + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Main where + +-- git-all.hs, version 1.0 (2012-08-06) +-- +-- by John Wiegley +-- +-- A utility for determining which Git repositories need actions to be taken +-- within them. + +import Control.Concurrent.Chan +import Control.Monad +import Control.Monad.Loops +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 Prelude + hiding (FilePath, drop, replicate, lines, take, length, unlines, map) +default (T.Text) + +version = "1.0.1" +copyright = "2012" +gitAllSummary = "git-all v" ++ version ++ ", (C) John Wiegley " ++ copyright + +data GitAll = GitAll + { pulls :: Bool + , untracked :: Bool + , verbose :: Bool + , debug :: Bool + , arguments :: [String] } + deriving (Data, Typeable, Show, Eq) + +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" + , arguments = def &= args &= typ "fetch | status" } &= + summary gitAllSummary &= + program "git-all" &= + help "Fetch or report status of all Git repositories under the current directory" + +main :: IO () +main = do + -- use 2 cores; this utility must be linked with -threaded + GHC.Conc.setNumCapabilities 2 + + -- process command-line options + args <- getArgs + opts <- (if L.null args then withArgs ["--help"] else id) (cmdArgs gitAll) + + 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 thread, so + -- that the list of directories is accumulated while we work on them + c <- newChan + forkIO $ findDirectories c ((".git" ==) . filename) ["."] + + -- 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 + +-- Primary logic + +checkGitDirectory :: GitAll -> FilePath -> IO () +checkGitDirectory opts dir = do + debugM "git-all" $ "Scanning " ++ asText dir + + url <- gitMaybe dir "config" ["svn-remote.svn.url"] + + case L.head (arguments opts) of + "fetch" -> + gitFetch dir url + + "status" -> do + branches <- gitLocalBranches dir + mapM_ (gitPushOrPull dir url (pulls opts)) branches + + gitStatus dir (untracked opts) + +-- Git command wrappers + +dirAsFile = fromText . T.init . toTextIgnore . directory + +gitStatus :: FilePath -> Bool -> IO () +gitStatus dir untracked = do + changes <- + git dir "status" + [ "--porcelain" + , append "--untracked-files=" (if untracked then "normal" else "no") ] + + putStr $ unpack $ topTen "STATUS" (dirAsFile dir) changes "==" + +gitFetch :: FilePath -> Maybe Text -> IO () +gitFetch dir url = do + output <- + if isNothing url + 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) + + putStr $ unpack $ topTen "FETCH" (dirAsFile dir) output "==" + +type CommitId = Text +type BranchInfo = (CommitId, Text) + +gitLocalBranches :: FilePath -> IO [BranchInfo] +gitLocalBranches dir = do + output <- git dir "for-each-ref" ["refs/heads/"] + return $ parseGitRefs (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 words' = T.words x + parseGitRefs [] = [] + +gitPushOrPull :: FilePath -> Maybe Text -> Bool -> BranchInfo -> IO () +gitPushOrPull dir url pulls branch = do + 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 + then + gitMaybe dir "rev-parse" [branchName] + else do + trunk <- gitMaybe dir "rev-parse" ["trunk"] + case trunk of + Nothing -> gitMaybe dir "rev-parse" ["git-svn"] + Just _ -> return trunk + + when (isJust remoteSha && fst branch /= fromJust remoteSha) $ do + let logArgs = ["--no-merges", "--oneline"] + 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 "==" + + when pulls $ do + pullLog <- git dir "log" ( logArgs + ++ [T.concat [fst branch, "..", sha], "--"]) + putStr $ unpack $ topTen "NEED PULL" (fromText branchLabel) pullLog "==" + +-- Utility functions + +doGit :: FilePath -> Text -> [Text] -> Sh Text +doGit dir com args = do + let gitDir = T.append "--git-dir=" (toTextIgnore dir) + let workDir = T.append "--work-tree=" (toTextIgnore (dirAsFile dir)) + run "git" $ [gitDir, workDir, com] ++ args + +git :: FilePath -> Text -> [Text] -> IO Text +git dir com args = + shelly $ silently $ errExit False $ do + text <- doGit dir com args + code <- lastExitCode + unless (code == 0) $ do + err <- lastStderr + liftIO $ putStr $ unpack $ topTen "FAILED" (dirAsFile dir) err "##" + return text + +gitMaybe :: FilePath -> Text -> [Text] -> IO (Maybe Text) +gitMaybe dir cmd args = + shelly $ silently $ errExit False $ do + text <- doGit dir cmd args + code <- lastExitCode + if code == 0 + then return . Just . L.head . lines $ text + else return Nothing + +topTen :: Text -> FilePath -> Text -> Text -> Text +topTen _ _ "" _ = "" +topTen category path content marker = + T.concat $ [ "\n", marker, " ", category, " ", marker, " " + , toTextIgnore path, "\n" + -- , unlines (L.take 10 ls) + , unlines (L.map (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 + +findDirectories :: Chan (Maybe FilePath) -> (FilePath -> Bool) -> [FilePath] -> IO () +findDirectories c pred 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. + + shelly $ filterM test_d dirs >>= + mapM_ (findFold (\_ path -> when (pred path) $ + liftIO . writeChan c . Just $ path) ()) + writeChan c Nothing + +asText = unpack . toTextIgnore + +-- git-all.hs ends here diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +git-all: Show status for all Git repositories in a directory (or current) + +Version 1.0, by John Wiegley + +To install, type "cabal install", and make sure that ~/.cabal/bin is on your +PATH. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs diff --git a/git-all.cabal b/git-all.cabal new file mode 100644 --- /dev/null +++ b/git-all.cabal @@ -0,0 +1,29 @@ +Name: git-all + +Version: 1.0.1 +Synopsis: Determine which Git repositories need to actions to be taken + +Description: A utility for determining which Git repositories need actions to be + taken within them. + +Homepage: https://github.com/jwiegley/git-all +License: BSD3 +License-file: LICENSE +Author: John Wiegley +Maintainer: John Wiegley +Category: Development +Build-type: Simple +Cabal-version: >= 1.8 + +Extra-Source-Files: README.md + +Executable git-all + Main-is: Main.hs + Ghc-options: -threaded + + Build-depends: base >= 4 && < 5, shelly, cmdargs, hslogger, regex-posix, + system-filepath, text, monad-loops + +Source-repository head + type: git + location: https://github.com/jwiegley/git-all