diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +[0.8.3](https://github.com/guillaume-nargeot/hpc-coveralls/issues?q=milestone:v0.8.3+is:closed) +----- +* Send git repository info when using other CI services than Travis (issue #37) + [0.8.2](https://github.com/guillaume-nargeot/hpc-coveralls/issues?q=milestone:v0.8.2+is:closed) ----- * Add option to send repo token (issue #36) diff --git a/hpc-coveralls.cabal b/hpc-coveralls.cabal --- a/hpc-coveralls.cabal +++ b/hpc-coveralls.cabal @@ -1,5 +1,5 @@ name: hpc-coveralls -version: 0.8.2 +version: 0.8.3 synopsis: Coveralls.io support for Haskell. description: This utility converts and sends Haskell projects hpc code coverage to @@ -51,6 +51,7 @@ HpcCoverallsCmdLine, Trace.Hpc.Coveralls.Config, Trace.Hpc.Coveralls.Curl, + Trace.Hpc.Coveralls.GitInfo, Trace.Hpc.Coveralls.Paths build-depends: aeson, @@ -60,6 +61,7 @@ cmdargs >= 0.10, curl >= 1.3.8, hpc >= 0.6, + process >= 1.1.0.1, retry >= 0.5, safe >= 0.3, split @@ -75,6 +77,7 @@ cmdargs >= 0.10, curl >= 1.3.8, hpc >= 0.6, + process >= 1.1.0.1, retry >= 0.5, safe >= 0.3, split diff --git a/src/HpcCoverallsMain.hs b/src/HpcCoverallsMain.hs --- a/src/HpcCoverallsMain.hs +++ b/src/HpcCoverallsMain.hs @@ -14,6 +14,7 @@ import Trace.Hpc.Coveralls import Trace.Hpc.Coveralls.Config (Config(Config)) import Trace.Hpc.Coveralls.Curl +import Trace.Hpc.Coveralls.GitInfo (getGitInfo) import Trace.Hpc.Coveralls.Util urlApiV1 :: String @@ -47,7 +48,8 @@ Nothing -> putStrLn "Please specify a target test suite name" >> exitSuccess Just config -> do (serviceName, jobId) <- getServiceAndJobID - coverallsJson <- generateCoverallsFromTix serviceName jobId config + gitInfo <- getGitInfo + coverallsJson <- generateCoverallsFromTix serviceName jobId gitInfo config when (displayReport hca) $ BSL.putStrLn $ encode coverallsJson let filePath = serviceName ++ "-" ++ jobId ++ ".json" writeJson filePath coverallsJson diff --git a/src/Trace/Hpc/Coveralls.hs b/src/Trace/Hpc/Coveralls.hs --- a/src/Trace/Hpc/Coveralls.hs +++ b/src/Trace/Hpc/Coveralls.hs @@ -19,6 +19,7 @@ import qualified Data.Map.Strict as M import System.Exit (exitFailure) import Trace.Hpc.Coveralls.Config +import Trace.Hpc.Coveralls.GitInfo (GitInfo) import Trace.Hpc.Coveralls.Lix import Trace.Hpc.Coveralls.Paths import Trace.Hpc.Coveralls.Types @@ -83,14 +84,16 @@ Mix _ _ _ _ mixEntries = mix getExprSource' = getExprSource $ lines source -toCoverallsJson :: String -> String -> Maybe String -> LixConverter -> TestSuiteCoverageData -> Value -toCoverallsJson serviceName jobId repoTokenM converter testSuiteCoverageData = - object $ mcons (("repo_token" .=) <$> repoTokenM) base +toCoverallsJson :: String -> String -> Maybe String -> GitInfo -> LixConverter -> TestSuiteCoverageData -> Value +toCoverallsJson serviceName jobId repoTokenM gitInfo converter testSuiteCoverageData = + object $ if serviceName == "travis-ci" then withRepoToken else withGitInfo where base = [ "service_job_id" .= jobId, "service_name" .= serviceName, "source_files" .= toJsonCoverageList testSuiteCoverageData] toJsonCoverageList = map (uncurry $ coverageToJson converter) . M.toList + withRepoToken = mcons (("repo_token" .=) <$> repoTokenM) base + withGitInfo = ("git" .= gitInfo) : withRepoToken mergeModuleCoverageData :: ModuleCoverageData -> ModuleCoverageData -> ModuleCoverageData mergeModuleCoverageData (source, mix, tixs1) (_, _, tixs2) = @@ -124,11 +127,12 @@ -- | Generate coveralls json formatted code coverage from hpc coverage data generateCoverallsFromTix :: String -- ^ CI name -> String -- ^ CI Job ID + -> GitInfo -- ^ Git repo information -> Config -- ^ hpc-coveralls configuration -> IO Value -- ^ code coverage result in json format -generateCoverallsFromTix serviceName jobId config = do +generateCoverallsFromTix serviceName jobId gitInfo config = do testSuitesCoverages <- mapM (`readCoverageData` excludedDirPatterns) testSuiteNames - return $ toCoverallsJson serviceName jobId repoTokenM converter $ mergeCoverageData testSuitesCoverages + return $ toCoverallsJson serviceName jobId repoTokenM gitInfo converter $ mergeCoverageData testSuitesCoverages where excludedDirPatterns = excludedDirs config testSuiteNames = testSuites config repoTokenM = repoToken config diff --git a/src/Trace/Hpc/Coveralls/GitInfo.hs b/src/Trace/Hpc/Coveralls/GitInfo.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Coveralls/GitInfo.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Trace.Hpc.Coveralls.GitInfo (getGitInfo, GitInfo) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (guard) +import Data.Aeson +import Data.List (nubBy) +import Data.Function (on) +import System.Process (readProcess) + +data GitInfo = GitInfo { headRef :: Commit + , branch :: String + , remotes :: [Remote] } + +instance ToJSON GitInfo where + toJSON i = object [ "head" .= headRef i + , "branch" .= branch i + , "remotes" .= remotes i] + +data Commit = Commit { hash :: String + , authorName :: String + , authorEmail :: String + , committerName :: String + , committerEmail :: String + , message :: String } + +instance ToJSON Commit where + toJSON c = object [ "id" .= hash c + , "author_name" .= authorName c + , "author_email" .= authorEmail c + , "committer_name" .= committerName c + , "committer_email" .= committerEmail c + , "message" .= message c ] + +data Remote = Remote { name :: String + , url :: String } + +instance ToJSON Remote where + toJSON r = object [ "name" .= name r + , "url" .= url r ] + +git :: [String] -> IO String +git args = init <$> readProcess "git" args [] -- init to strip trailing \n + +-- | Get information about the Git repo in the current directory. +getGitInfo :: IO GitInfo +getGitInfo = GitInfo <$> headRef <*> branch <*> getRemotes where + headRef = Commit <$> git ["rev-parse", "HEAD"] + <*> git ["log", "-1", "--pretty=%aN"] <*> git ["log", "-1", "--pretty=%aE"] + <*> git ["log", "-1", "--pretty=%cN"] <*> git ["log", "-1", "--pretty=%cE"] + <*> git ["log", "-1", "--pretty=%s"] + branch = git ["rev-parse", "--abbrev-ref", "HEAD"] + +getRemotes :: IO [Remote] +getRemotes = nubBy ((==) `on` name) <$> parseRemotes <$> git ["remote", "-v"] where + parseRemotes :: String -> [Remote] + parseRemotes input = do + line <- lines input + let fields = words line + guard $ length fields >= 2 + return $ Remote (head fields) (fields !! 1)