Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Stuff

  • Loading branch information...
commit fe1f1a397657eca7493dbd27c0452febb6c6192e 1 parent f64bbe1
Ian Duncan authored
54 Command/Update.hs
... ... @@ -0,0 +1,54 @@
  1 +{-# LANGUAGE KindSignatures #-}
  2 +module Command.Update where
  3 +import Control.Concurrent
  4 +import Control.Monad.Trans
  5 +import Control.Monad.Reader
  6 +import qualified Data.Text.Lazy as LT
  7 +import Shelly
  8 +default (LT.Text)
  9 +
  10 +type Ref = LT.Text
  11 +type Tracking = LT.Text
  12 +
  13 +data ConsoleMessage = Good
  14 + | Bad
  15 + | Ugly
  16 +
  17 +
  18 +command1' cmd cmdargs sub subargs = LT.init <$> command1 cmd cmdargs sub subargs
  19 +git = command1' "git" []
  20 +
  21 +needsStash = catchany_sh
  22 + (git "diff" ["--no-ext-diff", "--quiet", "--exit-code"] >> return False)
  23 + (const $ return True)
  24 +
  25 +smartStash a = do
  26 + shouldStash <- needsStash
  27 + when shouldStash $ git "stash" [] >> return ()
  28 + result <- a
  29 + when shouldStash $ git "stash" ["pop"] >> return ()
  30 + return a
  31 +
  32 +-- puts you on the new head of the most recent branch you were on.
  33 +-- if you were not on a branch, returns to the commit you were on.
  34 +smartCheckout a = do
  35 + location <- catchany_sh getBranchTip (const getRef)
  36 + result <- a
  37 + git "checkout" [location]
  38 + return a
  39 +
  40 +getRef = git "rev-parse" ["HEAD"]
  41 +getBranchTip = git "symbolic-ref" ["HEAD", "--short"]
  42 +
  43 +getTrackingBranches :: ShIO [(Ref, Tracking)]
  44 +getTrackingBranches = do
  45 + raw <- git "for-each-ref" ["--format=(\"%(refname:short)\", \"%(upstream:short)\")", "refs/heads"]
  46 + return $! filter (not . LT.null . snd) $ map read $ lines $ LT.unpack raw
  47 +
  48 +rebase local remote = git "rebase" [remote, local]
  49 +
  50 +update repo = {- notify_error $ -} chdir repo $ do
  51 + -- notify $ LT.append "Updating " $ toTextIgnore repo
  52 + git "fetch" []
  53 + updatable <- getTrackingBranches
  54 + smartCheckout $ smartStash $ mapM_ (uncurry rebase) updatable
31 GitMega.cabal
... ... @@ -0,0 +1,31 @@
  1 +-- Initial GitMega.cabal generated by cabal init. For further
  2 +-- documentation, see http://haskell.org/cabal/users-guide/
  3 +
  4 +name: GitMega
  5 +version: 0.1.0.0
  6 +synopsis: Common operations against lots of repos all at once
  7 +-- description:
  8 +homepage: http://github.com/iand675/megagit
  9 +license: BSD3
  10 +license-file: LICENSE
  11 +author: Ian Duncan
  12 +maintainer: ian@iankduncan.com
  13 +-- copyright:
  14 +category: Development
  15 +build-type: Simple
  16 +cabal-version: >=1.8
  17 +
  18 +executable GitMega
  19 + -- main-is:
  20 + -- other-modules:
  21 + extensions: OverloadedStrings,
  22 + ExtendedDefaultRules,
  23 + QuasiQuotes,
  24 + TemplateHaskell,
  25 + KindSignatures
  26 + ghc-options: -fno-warn-type-defaults,
  27 + -Wall
  28 + build-depends: base ==4.5.*,
  29 + text ==0.11.*,
  30 + shelly ==0.10.*,
  31 + shelly-extra ==0.2.*,
30 LICENSE
... ... @@ -0,0 +1,30 @@
  1 +Copyright (c) 2012, Ian Duncan
  2 +
  3 +All rights reserved.
  4 +
  5 +Redistribution and use in source and binary forms, with or without
  6 +modification, are permitted provided that the following conditions are met:
  7 +
  8 + * Redistributions of source code must retain the above copyright
  9 + notice, this list of conditions and the following disclaimer.
  10 +
  11 + * Redistributions in binary form must reproduce the above
  12 + copyright notice, this list of conditions and the following
  13 + disclaimer in the documentation and/or other materials provided
  14 + with the distribution.
  15 +
  16 + * Neither the name of Ian Duncan nor the names of other
  17 + contributors may be used to endorse or promote products derived
  18 + from this software without specific prior written permission.
  19 +
  20 +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  21 +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  22 +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  23 +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  24 +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  25 +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  26 +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  27 +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  28 +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  29 +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  30 +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
58 Main.hs
... ... @@ -0,0 +1,58 @@
  1 +module Main where
  2 +import Control.Concurrent
  3 +import Control.Monad
  4 +import qualified Data.Text.Lazy as LT
  5 +import GHC.Conc
  6 +import Shelly
  7 +import Shelly.Background
  8 +default (LT.Text)
  9 +
  10 +git = command1 "git" []
  11 +
  12 +branchInfo branch field = git "config" $ [LT.concat ["branch.", branch, ".", field]]
  13 +
  14 +upstream branch = do
  15 + status <- git "status" []
  16 + let uplines = map LT.pack . grep ("# Your branch" :: String) $ lines $ LT.unpack status
  17 + case uplines of
  18 + [] -> return Nothing
  19 + (x:_) -> (Just . LT.init) <$> (return (head uplines) -|- cmd "cut" "-d" "'" "-f" "2")
  20 +
  21 +isTracking branch = (not . any LT.null) <$> mapM (branchInfo branch) ["remote", "merge"]
  22 +
  23 +withStash a = do
  24 + stash <- git "stash" []
  25 + let didStash = null $ grep ("No local changes" :: String) $ lines $ LT.unpack stash
  26 + result <- a
  27 + when didStash $ git "stash" ["pop", "-q"] >> return ()
  28 + return a
  29 +
  30 +gitRepos :: [Shelly.FilePath] -> ShIO [Shelly.FilePath]
  31 +gitRepos = filterM (test_e . (</> ".git"))
  32 +
  33 +tellFinished chan repo = liftIO $ writeChan chan $ LT.append "Finished updating " $ toTextIgnore repo
  34 +
  35 +update chan gitRepo = chdir gitRepo $ do
  36 + liftIO $ writeChan chan $ LT.append "Updating " $ toTextIgnore gitRepo
  37 + git "fetch" []
  38 + branch <- LT.init <$> git "describe" ["--contains", "--all", "HEAD"]
  39 + notTracking <- isTracking branch
  40 + unlessM (isTracking branch) $ do
  41 + errorExit $ LT.concat ["\"", branch, "\" is not a tracking branch"]
  42 + remote <- upstream branch
  43 + case remote of
  44 + Nothing -> tellFinished chan gitRepo
  45 + Just r -> withStash (git "rebase" ["-p", r]) >> tellFinished chan gitRepo
  46 +
  47 +main = do
  48 + processorCount <- getNumProcessors
  49 + setNumCapabilities processorCount
  50 + outputChan <- newChan
  51 + shelly $ print_stdout False $ print_commands False $ do
  52 + dirs <- ls "."
  53 + repos <- gitRepos dirs
  54 + jobs processorCount $ \manager -> do
  55 + promises <- mapM (background manager . update outputChan) repos
  56 + verbosely $ replicateM_ (2 * length repos) $ (liftIO $ readChan outputChan) >>= echo
  57 +
  58 +
2  Setup.hs
... ... @@ -0,0 +1,2 @@
  1 +import Distribution.Simple
  2 +main = defaultMain

0 comments on commit fe1f1a3

Please sign in to comment.
Something went wrong with that request. Please try again.