diff --git a/hpc-coveralls.cabal b/hpc-coveralls.cabal --- a/hpc-coveralls.cabal +++ b/hpc-coveralls.cabal @@ -1,40 +1,21 @@ name: hpc-coveralls -version: 0.1.2 +version: 0.2.0 synopsis: Coveralls.io support for Haskell. description: - This utility converts and sends Haskell projects hpc code coverage to . - . - At the moment, only is supported, but other CI services will be supported soon. + This utility converts and sends Haskell projects hpc code coverage to + . . /Usage/ . - Commands to add to your project .travis.yml: + Commands to add to your project .travis.yml when using Travis CI: . > before_install: > - cabal install hpc-coveralls > script: > - cabal configure --enable-tests --enable-library-coverage && cabal build - > - run-cabal-test [optional-cabal-test-arguments] + > - run-cabal-test [options] [cabal-test-options] > after_script: - > - hpc-coveralls [your-test-suite-name] - . - /The run-cabal-test command/ - . - When using hpc 0.6, 'cabal test' outputs an error message and exits with the error code 1, which results in a build failure. - . - In order to prevent this from happening, hpc-coveralls provides the 'run-cabal-test' command which runs 'cabal test' and returns with 0 if the regex '^Test suite .*: FAIL$' never matches any line of the output. - . - This hpc issue should be fixed in version 0.7, which is provided by GHC 7.8 (Travis CI currently only provides GHC 7.6). - . - /Limitations/ - . - As Coveralls doesn't support yet partial-line coverage, the following convention is used to represent line coverage with line hit counts: - . - * 0 : the line is never hit, - . - * 1 : the line is partially covered, - . - * 2 : the line is fully covered. + > - hpc-coveralls [options] [test-suite-name] . Further information can be found in the . @@ -48,6 +29,8 @@ stability: experimental cabal-version: >= 1.8 tested-with: GHC == 7.6.3 +bug-reports: https://github.com/guillaume-nargeot/hpc-coveralls +homepage: https://github.com/guillaume-nargeot/hpc-coveralls/issues source-repository head type: git @@ -64,7 +47,8 @@ base < 5, bytestring >= 0.10, curl >= 1.3.8, - hpc >= 0.6.0.0 + hpc >= 0.6.0.0, + regex-posix executable hpc-coveralls hs-source-dirs: src @@ -73,8 +57,10 @@ aeson, base < 5, bytestring >= 0.10, + cmdargs >= 0.10, curl >= 1.3.8, - hpc >= 0.6.0.0 + hpc >= 0.6.0.0, + regex-posix ghc-options: -Wall -fwarn-tabs executable run-cabal-test @@ -83,7 +69,8 @@ build-depends: base < 5, process, - regex-posix + regex-posix, + split ghc-options: -Wall -fwarn-tabs test-suite test-all @@ -92,10 +79,9 @@ main-is: TestAll.hs build-depends: aeson, - base < 5, - bytestring >= 0.10, - curl >= 1.3.8, - hpc >= 0.6.0.0, - HUnit, - Cabal >= 1.9.2 + base, + bytestring, + curl, + hpc, + HUnit ghc-options: -Wall diff --git a/src/HpcCoverallsMain.hs b/src/HpcCoverallsMain.hs --- a/src/HpcCoverallsMain.hs +++ b/src/HpcCoverallsMain.hs @@ -1,37 +1,58 @@ module Main where +import Control.Monad import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.List +import Data.Maybe +import HpcCoverallsCmdLine +import System.Console.CmdArgs +import System.Environment (getEnv, getEnvironment) +import System.Exit (exitFailure, exitSuccess) import Trace.Hpc.Coveralls +import Trace.Hpc.Coveralls.Config import Trace.Hpc.Coveralls.Curl -import System.Environment (getArgs, getEnv, getEnvironment) -import System.Exit (exitSuccess) -import qualified Data.ByteString.Lazy.Char8 as BSL +urlApiV1 :: String +urlApiV1 = "https://coveralls.io/api/v1/jobs" + getServiceAndJobID :: IO (String, String) getServiceAndJobID = do env <- getEnvironment - case lookup "TRAVIS" env of - Just _ -> do - jobId <- getEnv "TRAVIS_JOB_ID" - return ("travis-ci", jobId) + case fmap snd $ find (isJust . flip lookup env . fst) ciEnvVars of + Just (ciName, jobIdVarName) -> do + jobId <- getEnv jobIdVarName + return (ciName, jobId) _ -> error "Unsupported CI service." + where ciEnvVars = [ + ("TRAVIS", ("travis-ci", "TRAVIS_JOB_ID")), + ("CIRCLECI", ("circleci", "CIRCLE_BUILD_NUM")), + ("SEMAPHORE", ("semaphore", "REVISION")), + ("JENKINS_URL", ("jenkins", "BUILD_ID")), + ("CI_NAME", ("codeship", "CI_BUILD_NUMBER"))] writeJson :: String -> Value -> IO () writeJson filePath = BSL.writeFile filePath . encode +toConfig :: HpcCoverallsArgs -> Maybe Config +toConfig hca = case testSuites hca of + [testSuite] -> case excludeDirs hca of + Nothing -> Just $ Config [testSuite] [] + Just dirs -> Just $ Config [testSuite] dirs + _ -> Nothing + main :: IO () main = do - args <- getArgs - case args of - ["--help"] -> usage >> exitSuccess - ["-h"] -> usage >> exitSuccess - [testName] -> do + hca <- cmdArgs hpcCoverallsArgs + case toConfig hca of + Nothing -> putStrLn "Please specify a target test suite name" >> exitSuccess + Just config -> do (serviceName, jobId) <- getServiceAndJobID - coverallsJson <- generateCoverallsFromTix serviceName jobId testName + coverallsJson <- generateCoverallsFromTix serviceName jobId config let filePath = serviceName ++ "-" ++ jobId ++ ".json" + when (displayReport hca) $ BSL.putStrLn $ encode coverallsJson writeJson filePath coverallsJson - response <- postJson filePath "https://coveralls.io/api/v1/jobs" - putStrLn response >> exitSuccess - _ -> usage >> exitSuccess - where - usage = putStrLn "Usage: hpc-coveralls [testName]" + response <- postJson filePath urlApiV1 + case response of + PostSuccess url -> putStrLn ("URL: " ++ url) >> exitSuccess + PostFailure msg -> putStrLn ("Error: " ++ msg) >> exitFailure diff --git a/src/RunCabalTestMain.hs b/src/RunCabalTestMain.hs --- a/src/RunCabalTestMain.hs +++ b/src/RunCabalTestMain.hs @@ -1,12 +1,17 @@ module Main where import Control.Monad +import Data.List +import Data.List.Split import GHC.IO.Handle import System.Exit (exitFailure, exitSuccess) import System.Environment (getArgs) import System.Process import Text.Regex.Posix +defaultCabalName :: String +defaultCabalName = "cabal" + isTestFailure :: String -> Bool isTestFailure line = line =~ "^Test suite .*: FAIL$" @@ -21,19 +26,31 @@ xs <- readLines h return (x : xs) -runCabalTest :: [String] -> IO Bool -runCabalTest args = do - (_, out, _, _) <- runInteractiveCommand ("cabal test " ++ unwords args) - liftM (not . any isTestFailure) (readLines out) +runCabalTest :: String -> [String] -> IO Bool +runCabalTest cabalName args = do + (_, out, err, _) <- runInteractiveCommand (cabalName ++ " test " ++ unwords args) + outResult <- liftM (not . any isTestFailure) (readLines out) + _ <- readLines err + return outResult +getCabalName :: [String] -> Maybe String +getCabalName [] = Just defaultCabalName +getCabalName [arg] = case splitOn "=" arg of + (_ : cabalName : _) -> Just cabalName + _ -> Nothing +getCabalName _ = Nothing + main :: IO () main = do - args <- getArgs - case args of + cmdArgs <- getArgs + case cmdArgs of ["--help"] -> usage >> exitSuccess ["-h"] -> usage >> exitSuccess - options -> do - result <- runCabalTest options - if result then exitSuccess else exitFailure - where - usage = putStrLn "Usage: run-cabal-test [options]" + options -> case mCabalName of + Just cabalName -> do + result <- runCabalTest cabalName cabalTestArgs + if result then exitSuccess else exitFailure + Nothing -> usage >> exitFailure + where (runCabalTestArgs, cabalTestArgs) = partition (=~ "^--cabal-name=.*") options + mCabalName = getCabalName runCabalTestArgs + where usage = putStrLn "Usage: run-cabal-test [run-cabal-test-options] [cabal-test-options]" 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 @@ -13,11 +13,16 @@ import Data.Aeson import Data.Aeson.Types () +import Data.List +import System.Exit (exitFailure) +import Text.Regex.Posix +import Trace.Hpc.Coveralls.Config import Trace.Hpc.Lix import Trace.Hpc.Mix import Trace.Hpc.Tix type CoverageData = ( + String, -- source file path String, -- file source code Mix, -- module index data TixModule) -- tixs recorded by hpc @@ -48,15 +53,14 @@ toSimpleCoverage lineCount = lixToSimpleCoverage . toLix lineCount coverageToJson :: CoverageData -> Value -coverageToJson (source, mix, tix) = object [ - "name" .= getFilePath mix, +coverageToJson (filePath, source, mix, tix) = object [ + "name" .= filePath, "source" .= source, "coverage" .= coverage] where coverage = toSimpleCoverage lineCount mixEntryTixs lineCount = length $ lines source mixEntryTixs = zip (getMixEntries mix) (tixModuleTixs tix) getMixEntries (Mix _ _ _ _ mixEntries) = mixEntries - getFilePath (Mix filePath _ _ _ _) = filePath toCoverallsJson :: String -> String -> [CoverageData] -> Value toCoverallsJson serviceName jobId coverageData = object [ @@ -64,29 +68,43 @@ "service_name" .= serviceName, "source_files" .= map coverageToJson coverageData] -toCoverageData :: String -> Tix -> IO [CoverageData] -toCoverageData name (Tix tixs) = do - mixs <- mapM readMix' tixs - sources <- mapM readSource mixs - return $ zip3 sources mixs tixs - where readMix' tix = readMix [mixPath] (Right tix) - where mixPath = mixDir ++ dirName ++ "/" - dirName = case span (/= '/') modName of - (_, []) -> name - (packageId, _) -> packageId - TixModule modName _ _ _ = tix - readSource (Mix filePath _ _ _ _) = readFile filePath +matchAny :: [String] -> String -> Bool +matchAny patterns fileName = any (fileName =~) $ map ("^" ++) patterns +readMix' :: String -> TixModule -> IO Mix +readMix' name tix = readMix [mixPath] (Right tix) + where mixPath = mixDir ++ dirName ++ "/" + dirName = case span (/= '/') modName of + (_, []) -> name + (packageId, _) -> packageId + TixModule modName _ _ _ = tix + +-- | Create a list of coverage data from the tix input +toCoverageData :: String -- ^ test suite name + -> Tix -- ^ tix data + -> [String] -- ^ excluded source folders + -> IO [CoverageData] -- ^ coverage data list +toCoverageData testSuiteName (Tix tixs) excludeDirPatterns = do + mixs <- mapM (readMix' testSuiteName) tixs + let files = map filePath mixs + sources <- mapM readFile files + let coverageDataList = zip4 files sources mixs tixs + return $ filter sourceDirFilter coverageDataList + where filePath (Mix fp _ _ _ _) = fp + sourceDirFilter = not . matchAny excludeDirPatterns . fst4 + fst4 (x, _, _, _) = x + -- | Generate coveralls json formatted code coverage from hpc coverage data generateCoverallsFromTix :: String -- ^ CI name -> String -- ^ CI Job ID - -> String -- ^ test suite name + -> Config -- ^ hpc-coveralls configuration -> IO Value -- ^ code coverage result in json format -generateCoverallsFromTix serviceName jobId name = do +generateCoverallsFromTix serviceName jobId config = do mtix <- readTix tixPath case mtix of - Nothing -> error $ "Couldn't find the file " ++ tixPath + Nothing -> error ("Couldn't find the file " ++ tixPath) >> exitFailure Just tixs -> do - coverageDatas <- toCoverageData name tixs + coverageDatas <- toCoverageData testSuiteName tixs (excludedDirs config) return $ toCoverallsJson serviceName jobId coverageDatas - where tixPath = tixDir ++ name ++ "/" ++ getTixFileName name + where tixPath = tixDir ++ testSuiteName ++ "/" ++ getTixFileName testSuiteName + testSuiteName = head (testSuiteNames config) -- multiple test suite mode is supported at the moment diff --git a/src/Trace/Hpc/Coveralls/Curl.hs b/src/Trace/Hpc/Coveralls/Curl.hs --- a/src/Trace/Hpc/Coveralls/Curl.hs +++ b/src/Trace/Hpc/Coveralls/Curl.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- | @@ -9,22 +10,39 @@ -- -- Functions for sending coverage report files over http. -module Trace.Hpc.Coveralls.Curl (postJson) where +module Trace.Hpc.Coveralls.Curl ( postJson, PostResult (..) ) where +import Data.Aeson +import Data.Aeson.Types (parseMaybe) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe import Network.Curl +-- | Result to the POST request to coveralls.io +data PostResult = + PostSuccess URLString -- ^ Coveralls job url + | PostFailure String -- ^ error message + +parseResponse :: CurlResponse -> PostResult +parseResponse r = case respCurlCode r of + CurlOK -> PostSuccess $ getField "url" + _ -> PostFailure $ getField "message" + where getField fieldName = fromJust $ mGetField fieldName + mGetField fieldName = do + result <- decode $ LBS.pack (respBody r) + parseMaybe (.: fieldName) result + httpPost :: String -> [HttpPost] httpPost path = [HttpPost "json_file" Nothing (ContentFile path) [] Nothing] -showResponse :: CurlResponse -> String -showResponse r = show (respCurlCode r) ++ show (respBody r) - -- | Send file content over HTTP using POST request -postJson :: String -> URLString -> IO String +postJson :: String -- ^ target file + -> URLString -- ^ target url + -> IO PostResult -- ^ POST request result postJson path url = do h <- initialize setopt h (CurlVerbose True) setopt h (CurlURL url) setopt h (CurlHttpPost $ httpPost path) r <- perform_with_response_ h - return $ showResponse r + return $ parseResponse r