git-all (empty) → 1.0.1

raw patch · 5 files changed

+289/−0 lines, 5 filesdep +basedep +cmdargsdep +hsloggersetup-changed

Dependencies added: base, cmdargs, hslogger, monad-loops, regex-posix, shelly, system-filepath, text

Files

LICENSE +28/−0
Main.hs +226/−0
README.md +6/−0
Setup.hs +0/−0
git-all.cabal +29/−0

+ LICENSE view

@@ -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.

+ Main.hs view

@@ -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 <johnw@newartisans.com>+--+-- 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: "<HASH> commit refs/heads/<NAME>"+  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

+ README.md view

@@ -0,0 +1,6 @@+git-all: Show status for all Git repositories in a directory (or current)++Version 1.0, by John Wiegley <johnw@newartisans.com>++To install, type "cabal install", and make sure that ~/.cabal/bin is on your+PATH.

+ Setup.hs view

+ git-all.cabal view

@@ -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 <johnw@newartisans.com>+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