Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Stuff

  • Loading branch information...
commit fe1f1a397657eca7493dbd27c0452febb6c6192e 1 parent f64bbe1
@iand675 authored
Showing with 175 additions and 0 deletions.
  1. +54 −0 Command/Update.hs
  2. +31 −0 GitMega.cabal
  3. +30 −0 LICENSE
  4. +58 −0 Main.hs
  5. +2 −0  Setup.hs
View
54 Command/Update.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE KindSignatures #-}
+module Command.Update where
+import Control.Concurrent
+import Control.Monad.Trans
+import Control.Monad.Reader
+import qualified Data.Text.Lazy as LT
+import Shelly
+default (LT.Text)
+
+type Ref = LT.Text
+type Tracking = LT.Text
+
+data ConsoleMessage = Good
+ | Bad
+ | Ugly
+
+
+command1' cmd cmdargs sub subargs = LT.init <$> command1 cmd cmdargs sub subargs
+git = command1' "git" []
+
+needsStash = catchany_sh
+ (git "diff" ["--no-ext-diff", "--quiet", "--exit-code"] >> return False)
+ (const $ return True)
+
+smartStash a = do
+ shouldStash <- needsStash
+ when shouldStash $ git "stash" [] >> return ()
+ result <- a
+ when shouldStash $ git "stash" ["pop"] >> return ()
+ return a
+
+-- puts you on the new head of the most recent branch you were on.
+-- if you were not on a branch, returns to the commit you were on.
+smartCheckout a = do
+ location <- catchany_sh getBranchTip (const getRef)
+ result <- a
+ git "checkout" [location]
+ return a
+
+getRef = git "rev-parse" ["HEAD"]
+getBranchTip = git "symbolic-ref" ["HEAD", "--short"]
+
+getTrackingBranches :: ShIO [(Ref, Tracking)]
+getTrackingBranches = do
+ raw <- git "for-each-ref" ["--format=(\"%(refname:short)\", \"%(upstream:short)\")", "refs/heads"]
+ return $! filter (not . LT.null . snd) $ map read $ lines $ LT.unpack raw
+
+rebase local remote = git "rebase" [remote, local]
+
+update repo = {- notify_error $ -} chdir repo $ do
+ -- notify $ LT.append "Updating " $ toTextIgnore repo
+ git "fetch" []
+ updatable <- getTrackingBranches
+ smartCheckout $ smartStash $ mapM_ (uncurry rebase) updatable
View
31 GitMega.cabal
@@ -0,0 +1,31 @@
+-- Initial GitMega.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: GitMega
+version: 0.1.0.0
+synopsis: Common operations against lots of repos all at once
+-- description:
+homepage: http://github.com/iand675/megagit
+license: BSD3
+license-file: LICENSE
+author: Ian Duncan
+maintainer: ian@iankduncan.com
+-- copyright:
+category: Development
+build-type: Simple
+cabal-version: >=1.8
+
+executable GitMega
+ -- main-is:
+ -- other-modules:
+ extensions: OverloadedStrings,
+ ExtendedDefaultRules,
+ QuasiQuotes,
+ TemplateHaskell,
+ KindSignatures
+ ghc-options: -fno-warn-type-defaults,
+ -Wall
+ build-depends: base ==4.5.*,
+ text ==0.11.*,
+ shelly ==0.10.*,
+ shelly-extra ==0.2.*,
View
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Ian Duncan
+
+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 Ian Duncan nor the names of other
+ 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.
View
58 Main.hs
@@ -0,0 +1,58 @@
+module Main where
+import Control.Concurrent
+import Control.Monad
+import qualified Data.Text.Lazy as LT
+import GHC.Conc
+import Shelly
+import Shelly.Background
+default (LT.Text)
+
+git = command1 "git" []
+
+branchInfo branch field = git "config" $ [LT.concat ["branch.", branch, ".", field]]
+
+upstream branch = do
+ status <- git "status" []
+ let uplines = map LT.pack . grep ("# Your branch" :: String) $ lines $ LT.unpack status
+ case uplines of
+ [] -> return Nothing
+ (x:_) -> (Just . LT.init) <$> (return (head uplines) -|- cmd "cut" "-d" "'" "-f" "2")
+
+isTracking branch = (not . any LT.null) <$> mapM (branchInfo branch) ["remote", "merge"]
+
+withStash a = do
+ stash <- git "stash" []
+ let didStash = null $ grep ("No local changes" :: String) $ lines $ LT.unpack stash
+ result <- a
+ when didStash $ git "stash" ["pop", "-q"] >> return ()
+ return a
+
+gitRepos :: [Shelly.FilePath] -> ShIO [Shelly.FilePath]
+gitRepos = filterM (test_e . (</> ".git"))
+
+tellFinished chan repo = liftIO $ writeChan chan $ LT.append "Finished updating " $ toTextIgnore repo
+
+update chan gitRepo = chdir gitRepo $ do
+ liftIO $ writeChan chan $ LT.append "Updating " $ toTextIgnore gitRepo
+ git "fetch" []
+ branch <- LT.init <$> git "describe" ["--contains", "--all", "HEAD"]
+ notTracking <- isTracking branch
+ unlessM (isTracking branch) $ do
+ errorExit $ LT.concat ["\"", branch, "\" is not a tracking branch"]
+ remote <- upstream branch
+ case remote of
+ Nothing -> tellFinished chan gitRepo
+ Just r -> withStash (git "rebase" ["-p", r]) >> tellFinished chan gitRepo
+
+main = do
+ processorCount <- getNumProcessors
+ setNumCapabilities processorCount
+ outputChan <- newChan
+ shelly $ print_stdout False $ print_commands False $ do
+ dirs <- ls "."
+ repos <- gitRepos dirs
+ jobs processorCount $ \manager -> do
+ promises <- mapM (background manager . update outputChan) repos
+ verbosely $ replicateM_ (2 * length repos) $ (liftIO $ readChan outputChan) >>= echo
+
+
View
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
Please sign in to comment.
Something went wrong with that request. Please try again.