git-all 1.6.0 → 1.8.1
raw patch · 2 files changed
+49/−43 lines, 2 filesdep +directorydep +filepathdep −system-fileiodep −system-filepath
Dependencies added: directory, filepath
Dependencies removed: system-fileio, system-filepath
Files
- Main.hs +45/−39
- git-all.cabal +4/−4
Main.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -21,18 +22,16 @@ 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.Directory+import System.FilePath.Posix hiding ((</>)) import System.Log.Logger import System.Posix.Files import Text.Regex.Posix@@ -89,22 +88,24 @@ 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)+ (let xs = case arguments opts of+ [] -> ["."]+ (_:rest) -> if L.null rest then ["."] else rest+ in 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)+ mapM_ (runGitCmd opts >=> putStr . unpack)+ (catMaybes' dirs) stopGlobalPool where runGitCmd :: GitAll -> (FilePath, FilePath) -> IO Text- runGitCmd opts = flip execStateT "" . uncurry (checkGitDirectory opts)+ runGitCmd opts entry = do+ debugM "git-all" $ "Running command for " ++ Prelude.show entry+ execStateT (uncurry (checkGitDirectory opts) entry) "" catMaybes' :: [Maybe a] -> [a] catMaybes' [] = []@@ -119,29 +120,24 @@ 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+ "Scanning " ++ gitDir ++ " => " ++ workTree url <- gitMaybe gitDir workTree "config" ["svn-remote.svn.url"] - case L.head (arguments opts) of- "fetch" ->+ case arguments opts of+ [] -> gitStatus gitDir workTree (untracked opts)+ ("fetch":_) -> gitFetch gitDir workTree url - "status" -> do+ ("status":_) -> do mapM_ (gitPushOrPull gitDir workTree url (pulls opts)) =<< gitLocalBranches gitDir workTree gitStatus gitDir workTree (untracked opts) - cmd -> gitCommand gitDir workTree (T.pack cmd)+ (cmd:_) -> gitCommand gitDir workTree (T.pack cmd) -- Git command wrappers @@ -185,8 +181,9 @@ -- 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+ case T.words x of+ (hash:_:ref:_) -> (hash, T.drop 11 ref) : parseGitRefs xs+ _ -> parseGitRefs xs -- Skip malformed lines gitPushOrPull :: FilePath -> FilePath -> Maybe Text -> Bool -> BranchInfo -> IOState () gitPushOrPull gitDir workTree url doPulls branch = do@@ -221,9 +218,10 @@ 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)+ liftIO $ debugM "git-all" $ "git " ++ Prelude.show args_+ run "git" args_+ where+ args_ = "--git-dir":pack gitDir:"--work-tree":pack workTree:com:gitArgs git :: FilePath -> FilePath -> Text -> [Text] -> IOState Text git gitDir workTree com gitArgs = do@@ -246,7 +244,9 @@ text <- doGit gitDir workTree gitCmd gitArgs code <- lastExitCode if code == 0- then return . Just . L.head . T.lines $ text+ then return $ case T.lines text of+ [] -> Nothing+ (firstLine:_) -> Just firstLine else return Nothing topTen :: Text -> FilePath -> Text -> Text -> Text@@ -259,7 +259,7 @@ ++ (let len = L.length (L.drop 10 ls') in case len of 0 -> []- _ -> ["... (and " , pack (show len) , " more)\n"])+ _ -> ["... (and " , pack (Prelude.show len) , " more)\n"]) where ls' = T.lines content findDirsContainingW@@ -278,22 +278,28 @@ -> IO () findDirsContaining c curDepth p = do status <- if curDepth == 0- then getFileStatus (toString p)- else getSymbolicLinkStatus (toString p)+ then getFileStatus p+ else getSymbolicLinkStatus p - when (filename p == ".git") $ do+ debugM "git-all" $ "p = " ++ Prelude.show p+ debugM "git-all" $ "takeFileName p = " ++ Prelude.show (takeFileName p)+ when (takeFileName p == ".git") $ do+ debugM "git-all" "is .git" when (isRegularFile status) $ do- t <- readFile (toString p)+ debugM "git-all" ".git is regular file"+ t <- readFile 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))+ writeChan c (Just (takeDirectory p </> fromText (T.strip (T.pack (L.drop 8 t))),+ takeDirectory p))+ when (isDirectory status) $ do+ debugM "git-all" ".git is directory"+ writeChan c (Just (p, takeDirectory p)) when (isDirectory status &&- filename p `notElem` ["CVS", ".svn", ".deps", "_darcs", "CMakeFiles"]) $ do+ takeFileName p `notElem` ["CVS", ".svn", ".deps", "_darcs", "CMakeFiles"]) $ do+ debugM "git-all" $ p ++ " is not a special directory, recursing" files <- listDirectory p- let func = findDirsContainingW c (curDepth + 1)+ let func file = findDirsContainingW c (curDepth + 1) (p </> file) if curDepth == 0 then parallel_ $ L.map func files else mapM_ func files
git-all.cabal view
@@ -1,6 +1,6 @@ Name: git-all -Version: 1.6.0+Version: 1.8.1 Synopsis: Determine which Git repositories need actions to be taken Description: A utility for determining which Git repositories need actions to be@@ -13,7 +13,7 @@ Maintainer: John Wiegley <johnw@newartisans.com> Category: Development Build-type: Simple-Cabal-version: >= 1.8+Cabal-version: >= 1.10 Extra-Source-Files: README.md @@ -22,8 +22,8 @@ Ghc-options: -threaded Build-depends: base >= 4 && < 5, shelly, cmdargs, hslogger, regex-posix,- system-filepath, text, transformers, parallel-io, unix,- system-fileio+ directory, transformers, parallel-io, text, unix, filepath+ default-language: Haskell2010 Source-repository head type: git