hpc-coveralls 0.1.2 → 0.2.0
raw patch · 5 files changed
+149/−89 lines, 5 filesdep +cmdargsdep +splitdep −Cabaldep ~basedep ~bytestringdep ~curl
Dependencies added: cmdargs, split
Dependencies removed: Cabal
Dependency ranges changed: base, bytestring, curl, hpc
Files
- hpc-coveralls.cabal +20/−34
- src/HpcCoverallsMain.hs +39/−18
- src/RunCabalTestMain.hs +28/−11
- src/Trace/Hpc/Coveralls.hs +38/−20
- src/Trace/Hpc/Coveralls/Curl.hs +24/−6
hpc-coveralls.cabal view
@@ -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 <http://coveralls.io/ coverall.io>.- .- At the moment, only <http://travis-ci.org Travis CI> is supported, but other CI services will be supported soon.+ This utility converts and sends Haskell projects hpc code coverage to+ <http://coveralls.io/ coverall.io>. . /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 <https://github.com/guillaume-nargeot/hpc-coveralls README>. @@ -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
src/HpcCoverallsMain.hs view
@@ -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
src/RunCabalTestMain.hs view
@@ -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]"
src/Trace/Hpc/Coveralls.hs view
@@ -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
src/Trace/Hpc/Coveralls/Curl.hs view
@@ -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