diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs diff --git a/git-gpush.cabal b/git-gpush.cabal new file mode 100644 --- /dev/null +++ b/git-gpush.cabal @@ -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 +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