Merge pull request #37 from rimmington/gitinfo

Send Git info when not on Travis CI

hpc-coveralls.cabal

@@ -60,6 +60,7 @@ library
     cmdargs >= 0.10,
     curl >= 1.3.8,
     hpc >= 0.6,
+    process >= 1.1.0.1,
     retry >= 0.5,
     safe >= 0.3,
     split
@@ -75,6 +76,7 @@ executable hpc-coveralls
     cmdargs >= 0.10,
     curl >= 1.3.8,
     hpc >= 0.6,
+    process >= 1.1.0.1,
     retry >= 0.5,
     safe >= 0.3,
     split

src/HpcCoverallsMain.hs

@@ -14,6 +14,7 @@ import           System.Exit (exitFailure, exitSuccess)
 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 @@ main = do
         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

src/Trace/Hpc/Coveralls.hs

@@ -19,6 +19,7 @@ import           Data.List
 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 @@ coverageToJson converter filePath (source, mix, tixs) = object [
           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 @@ readCoverageData testSuiteName excludeDirPatterns = do
 -- | 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

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)