diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Guillaume Nargeot + +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 Guillaume Nargeot nor the names of other + 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hpc-coveralls.cabal b/hpc-coveralls.cabal new file mode 100644 --- /dev/null +++ b/hpc-coveralls.cabal @@ -0,0 +1,101 @@ +name: hpc-coveralls +version: 0.1.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. + . + /Usage/ + . + Commands to add to your project .travis.yml: + . + > before_install: + > - cabal install hpc-coveralls + > script: + > - cabal configure --enable-tests --enable-library-coverage && cabal build + > - run-cabal-test [optional-cabal-test-arguments] + > 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. + . + Further information can be found in the . + +license: BSD3 +license-file: LICENSE +author: Guillaume Nargeot +maintainer: Guillaume Nargeot +copyright: (c) 2014 Guillaume Nargeot +category: Control +build-type: Simple +stability: experimental +cabal-version: >= 1.8 +tested-with: GHC == 7.6.3 + +source-repository head + type: git + location: https://github.com/guillaume-nargeot/hpc-coveralls.git + +library + hs-source-dirs: src + exposed-modules: + Trace.Hpc.Coveralls, + Trace.Hpc.Coveralls.Curl, + Trace.Hpc.Lix + build-depends: + aeson, + base < 5, + bytestring >= 0.10, + curl >= 1.3.8, + hpc >= 0.6.0.0 + +executable hpc-coveralls + hs-source-dirs: src + main-is: HpcCoverallsMain.hs + build-depends: + aeson, + base < 5, + bytestring >= 0.10, + curl >= 1.3.8, + hpc >= 0.6.0.0 + ghc-options: -Wall -fwarn-tabs + +executable run-cabal-test + hs-source-dirs: src + main-is: RunCabalTestMain.hs + build-depends: + base < 5, + process, + regex-posix + ghc-options: -Wall -fwarn-tabs + +test-suite test-all + hs-source-dirs: src, test + type: exitcode-stdio-1.0 + 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 + ghc-options: -Wall diff --git a/src/HpcCoverallsMain.hs b/src/HpcCoverallsMain.hs new file mode 100644 --- /dev/null +++ b/src/HpcCoverallsMain.hs @@ -0,0 +1,37 @@ +module Main where + +import Data.Aeson +import Trace.Hpc.Coveralls +import Trace.Hpc.Coveralls.Curl +import System.Environment (getArgs, getEnv, getEnvironment) +import System.Exit (exitSuccess) +import qualified Data.ByteString.Lazy.Char8 as BSL + +getServiceAndJobID :: IO (String, String) +getServiceAndJobID = do + env <- getEnvironment + case lookup "TRAVIS" env of + Just _ -> do + jobId <- getEnv "TRAVIS_JOB_ID" + return ("travis-ci", jobId) + _ -> error "Unsupported CI service." + +writeJson :: String -> Value -> IO () +writeJson filePath = BSL.writeFile filePath . encode + +main :: IO () +main = do + args <- getArgs + case args of + ["--help"] -> usage >> exitSuccess + ["-h"] -> usage >> exitSuccess + [testName] -> do + (serviceName, jobId) <- getServiceAndJobID + coverallsJson <- generateCoverallsFromTix serviceName jobId testName + let filePath = serviceName ++ "-" ++ jobId ++ ".json" + writeJson filePath coverallsJson + response <- postJson filePath "https://coveralls.io/api/v1/jobs" + putStrLn response >> exitSuccess + _ -> usage >> exitSuccess + where + usage = putStrLn "Usage: hpc-coveralls [testName]" diff --git a/src/RunCabalTestMain.hs b/src/RunCabalTestMain.hs new file mode 100644 --- /dev/null +++ b/src/RunCabalTestMain.hs @@ -0,0 +1,39 @@ +module Main where + +import Control.Monad +import GHC.IO.Handle +import System.Exit (exitFailure, exitSuccess) +import System.Environment (getArgs) +import System.Process +import Text.Regex.Posix + +isTestFailure :: String -> Bool +isTestFailure line = line =~ "^Test suite .*: FAIL$" + +readLines :: Handle -> IO [String] +readLines h = do + isEOF <- hIsEOF h + if isEOF + then return [] + else do + x <- hGetLine h + putStrLn x + 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) + +main :: IO () +main = do + args <- getArgs + case args 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]" diff --git a/src/Trace/Hpc/Coveralls.hs b/src/Trace/Hpc/Coveralls.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Coveralls.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Trace.Hpc.Coveralls +-- Copyright: (c) 2014 Guillaume Nargeot +-- License: BSD3 +-- Maintainer: Guillaume Nargeot +-- Stability: experimental +-- +-- Types and functions for converting and sending hpc output to coveralls.io. + +module Trace.Hpc.Coveralls ( generateCoverallsFromTix ) where + +import Data.Aeson +import Data.Aeson.Types () +import Trace.Hpc.Lix +import Trace.Hpc.Mix +import Trace.Hpc.Tix + +type CoverageData = ( + String, -- file source code + Mix, -- module index data + TixModule) -- tixs recorded by hpc + +-- single file coverage data in the format defined by coveralls.io +type SimpleCoverage = [CoverageEntry] + +-- Is there a way to restrict this to only Number and Null? +type CoverageEntry = Value + +hpcDir :: String +hpcDir = "dist/hpc/" + +tixDir :: String +tixDir = hpcDir ++ "tix/" + +mixDir :: String +mixDir = hpcDir ++ "mix/" + +lixToSimpleCoverage :: Lix -> SimpleCoverage +lixToSimpleCoverage = map conv + where conv Full = Number 2 + conv Partial = Number 1 + conv None = Number 0 + conv Irrelevant = Null + +toSimpleCoverage :: Int -> [(MixEntry, Integer)] -> SimpleCoverage +toSimpleCoverage lineCount = lixToSimpleCoverage . toLix lineCount + +coverageToJson :: CoverageData -> Value +coverageToJson (source, mix, tix) = object [ + "name" .= getFilePath mix, + "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 [ + "service_job_id" .= jobId, + "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) + mixPath = mixDir ++ name ++ "/" + readSource (Mix filePath _ _ _ _) = readFile filePath + +-- | Generate coveralls json formatted code coverage from hpc coverage data +generateCoverallsFromTix :: String -- ^ CI name + -> String -- ^ CI Job ID + -> String -- ^ test suite name + -> IO Value -- ^ code coverage result in json format +generateCoverallsFromTix serviceName jobId name = do + mtix <- readTix tixPath + case mtix of + Nothing -> error $ "Couldn't find the file " ++ tixPath + Just tixs -> do + coverageDatas <- toCoverageData name tixs + return $ toCoverallsJson serviceName jobId coverageDatas + where tixPath = tixDir ++ name ++ "/" ++ getTixFileName name diff --git a/src/Trace/Hpc/Coveralls/Curl.hs b/src/Trace/Hpc/Coveralls/Curl.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Coveralls/Curl.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- | +-- Module: Trace.Hpc.Coveralls.Curl +-- Copyright: (c) 2014 Guillaume Nargeot +-- License: BSD3 +-- Maintainer: Guillaume Nargeot +-- Stability: experimental +-- +-- Functions for sending coverage report files over http. + +module Trace.Hpc.Coveralls.Curl (postJson) where + +import Network.Curl + +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 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 diff --git a/src/Trace/Hpc/Lix.hs b/src/Trace/Hpc/Lix.hs new file mode 100644 --- /dev/null +++ b/src/Trace/Hpc/Lix.hs @@ -0,0 +1,51 @@ +-- | +-- Module: Trace.Hpc.Lix +-- Copyright: (c) 2014 Guillaume Nargeot +-- License: BSD3 +-- Maintainer: Guillaume Nargeot +-- Stability: experimental +-- Portability: portable +-- +-- Types and functions for converting hpc output to line-based code coverage data. + +module Trace.Hpc.Lix where + +import Data.List +import Data.Ord +import Prelude hiding (getLine) +import Trace.Hpc.Mix +import Trace.Hpc.Util + +data Hit = Full | Partial | None | Irrelevant deriving (Eq, Show) + +type Lix = [Hit] + +groupByIndex :: Int -> [(Int, a)] -> [[a]] +groupByIndex size = take size . flip (++) (repeat []) . groupByIndex' 0 [] + where groupByIndex' _ ys [] = [ys] + groupByIndex' i ys xx@((xi, x) : xs) = if xi == i + then groupByIndex' i (x : ys) xs + else ys : groupByIndex' (i + 1) [] xx + +toHit :: [Bool] -> Hit +toHit [] = Irrelevant +toHit [x] = if x then Full else None +toHit xs + | and xs = Full + | or xs = Partial + | otherwise = None + +getLine :: MixEntry -> Int +getLine = fffst . fromHpcPos . fst + where fffst (x, _, _, _) = x + +toLineHit :: (MixEntry, Integer) -> (Int, Bool) +toLineHit (entry, cnt) = (getLine entry - 1, cnt > 0) + +-- | Convert hpc coverage entries into a line based coverage format +toLix :: Int -- ^ Source line count + -> [(MixEntry, Integer)] -- ^ Mix entries and associated hit count + -> Lix -- ^ Line coverage +toLix lineCount entries = map toHit (groupByIndex lineCount sortedLineHits) + where sortedLineHits = sortBy (comparing fst) lineHits + lineHits = map toLineHit entries diff --git a/test/TestAll.hs b/test/TestAll.hs new file mode 100644 --- /dev/null +++ b/test/TestAll.hs @@ -0,0 +1,15 @@ +module Main where + +import System.Exit ( exitFailure, exitSuccess ) +import Test.HUnit +import TestHpcLix + +allTests :: [Test] +allTests = [testHpcLix] + +main :: IO Counts +main = do + cnt <- runTestTT (test allTests) + if errors cnt + failures cnt == 0 + then exitSuccess + else exitFailure