git-gpush (empty) → 1.3.1
raw patch · 5 files changed
+244/−0 lines, 5 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, gitlib, gitlib-libgit2, hslogger, old-locale, optparse-applicative, shelly, system-fileio, system-filepath, tagged, text, time, transformers
Files
- LICENSE +28/−0
- Main.hs +175/−0
- README.md +0/−0
- Setup.hs +0/−0
- git-gpush.cabal +41/−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,175 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Main where++import Control.Monad+import Control.Monad.IO.Class (MonadIO(..))+import Data.Char+import Data.Foldable hiding (concat, concatMap, elem)+import Data.List+import Data.Maybe+import Data.Tagged+import qualified Data.Text as T+#if MIN_VERSION_shelly(1, 0, 0)+import Data.Text (Text)+import qualified Data.Text as TL hiding (tails)+#else+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL hiding (tails)+#endif+import Git hiding (Options)+import Git.Libgit2 (lgFactory, withLibGitDo)+import Options.Applicative+import Prelude hiding (FilePath, null)+import Shelly++toStrict :: TL.Text -> T.Text+#if MIN_VERSION_shelly(1, 0, 0)+toStrict = id+#else+toStrict = TL.toStrict+#endif++fromStrict :: T.Text -> TL.Text+#if MIN_VERSION_shelly(1, 0, 0)+fromStrict = id+#else+fromStrict = TL.fromStrict+#endif++instance Read FilePath++data Options = Options+ { verbose :: Bool+ , dryRun :: Bool+ , remote :: Maybe String+ , args :: [String]+ }++options :: Parser Options+options = Options+ <$> switch (short 'v' <> long "verbose" <> help "Display info")+ <*> switch (short 'n' <> long "dry-run" <> help "Dry run")+ <*> argument (Just . Just) (value Nothing)+ <*> arguments Just hidden++volume :: Options -> Sh a -> Sh a+volume opts = if verbose opts then verbosely else silently++sh :: MonadIO m => Options -> Sh a -> m a+sh opts = shelly . volume opts++git :: [Text] -> Sh Text+git = run "git"++git_ :: [Text] -> Sh ()+git_ = run_ "git"++main :: IO ()+main = withLibGitDo $ execParser opts >>= pushToGitHub+ where+ opts = info (helper <*> options)+ (fullDesc <> progDesc desc <> header hdr)+ hdr = "git-gpush 1.0.0 - push to GitHub with smarter behavior"+ desc = "\nDescription goes here."++pushToGitHub :: Options -> IO ()+pushToGitHub opts = do+ gd <- fromText . TL.init+ <$> sh opts (run "git" ["rev-parse", "--git-dir"])++ remoteName <- case remote opts of+ Nothing -> sh opts $ getRemoteName gd+ Just x -> return (TL.pack x)++ remoteHead <-+ head . TL.words . TL.init+ <$> sh opts (git [ "ls-remote", remoteName, "HEAD" ])++ withRepository lgFactory gd $ do+ cref <- fromJust <$> resolveReference "HEAD"+ hc <- resolveCommitRef cref+ rcoid <- Tagged <$> parseOid (toStrict remoteHead)+ objs <- missingObjects+ (Just (CommitObjectId rcoid))+ (CommitObjectId (commitOid hc))+ for_ objs $ \obj -> case obj of+ Git.CommitObj cref -> do+ commit <- resolveCommitRef cref+ sh opts $ processCommitTags (commitLog commit)+ _ -> return ()++ unless (dryRun opts) $+ sh opts $ git_ $ [ "push", remoteName ] <> map TL.pack (args opts)++getRemoteName :: FilePath -> Sh Text+getRemoteName gd = do+ mref <- liftIO $ withRepository lgFactory gd $ lookupReference "HEAD"+ case mref of+ Nothing -> error "Could not find HEAD"+ Just (Reference _ (RefObj _)) ->+ error "Cannot push from a detached HEAD"+ Just (Reference _ (RefSymbolic (fromStrict -> branch)))+ | "refs/heads/" `TL.isPrefixOf` branch ->+ TL.init <$> git [ "config"+ , "branch." <> base branch <> ".remote" ]+ | otherwise ->+ error "Cannot push from a branch outside refs/heads"+ where+ base = TL.drop (TL.length "refs/heads/")++data CommitTag+ = ConfirmTag+ { confirmIssue :: Text+ , confirmReport :: Maybe Text+ }+ deriving (Eq, Show)++findTags :: Text -> [CommitTag]+findTags = concatMap go . tails . map norm . TL.words+ where+ go [] = []+ go [_] = []+ go ["confirm", TL.splitOn ":" -> [issue]] =+ [ ConfirmTag (TL.tail issue) Nothing | isIssue issue ]+ go ["confirm", TL.splitOn ":" -> [issue, report]] =+ [ ConfirmTag (TL.tail issue) (Just report) | isIssue issue ]+ go _ = []++ isIssue issue = not (TL.null issue) && TL.head issue == '#'++ norm = TL.filter $ \c -> c `elem` "#:_-" || isDigit c || isLetter c++processCommitTags :: T.Text -> Sh ()+processCommitTags msg =+ for_ (findTags (fromStrict msg)) $ \tag -> case tag of+ ConfirmTag issue mreport -> do+ mreport' <- case mreport of+ x@(Just _) -> return x+ Nothing -> errExit False $ do+ who <- git [ "config", "fpco.directreport" ]+ ec <- lastExitCode+ return $ if ec == 0+ then Just (TL.init who)+ else Nothing++ -- jww (2013-04-28): Instead of using ghi here, we should use the+ -- github library, after reading in ghi.token.+ run_ "ghi"+ $ [ "edit" ]+ <> [ x | x <- [ "-u", fromJust mreport' ], isJust mreport' ]+ <> [ issue ]+ run_ "ghi" [ "comment"+ , "-m", "Please confirm that this has been fixed."+ , issue ]+ run_ "ghi" [ "label", issue, "-a", "need confirmation" ]++-- Main.hs (git-gpush) ends here
+ README.md view
+ Setup.hs view
+ git-gpush.cabal view
@@ -0,0 +1,41 @@+Name: git-gpush+Version: 1.3.1++Synopsis: More intelligent push-to-GitHub utility.+Description: More intelligent push-to-GitHub utility.++Homepage: git://github.com/fpco/gitlib+License: BSD3+License-file: LICENSE+Author: John Wiegley+Maintainer: John Wiegley <johnw@fpcomplete.com>+Category: Development+Build-type: Simple+Cabal-version: >= 1.10++Extra-Source-Files: README.md++Executable git-gpush+ Main-is: Main.hs+ Default-language: Haskell2010+ ghc-options: -Wall++ Build-depends: base >= 4 && < 5+ , bytestring >= 0.9.2.1+ , containers >= 0.4.2.1+ , gitlib >= 1.3.1+ , gitlib-libgit2 >= 1.3.1+ , hslogger >= 1.2+ , old-locale >= 1.0.0.4+ , optparse-applicative >= 0.5.2.1+ , shelly >= 0.14+ , system-fileio >= 0.3.11+ , system-filepath >= 0.4.7+ , tagged >= 0.4.5+ , text >= 0.11.2+ , time >= 1.4+ , transformers >= 0.3.0.0++Source-repository head+ type: git+ location: git://github.com/fpco/gitlib