diff --git a/USAGE.txt b/USAGE.txt --- a/USAGE.txt +++ b/USAGE.txt @@ -8,3 +8,9 @@ --repo-token= Coveralls repo token --partial-coverage allow partial line coverage --dont-send display Coveralls JSON instead of sending it + --fetch-coverage fetch and display Coveralls's overall coverage + +Multiple packages: + Use "combined" and "all" as package-name and suite-name resp. in +order to use all packages that stack has tested from a multiple +package repo. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,7 +3,7 @@ module Main where -import Control.Monad (unless) +import Control.Monad (unless, when) import Data.Aeson (encode) import qualified Data.ByteString.Lazy as BSL import Data.List (find) @@ -18,6 +18,7 @@ import SHC.Api import SHC.Coverage +import SHC.Stack import SHC.Types import SHC.Utils @@ -56,16 +57,19 @@ unless (not $ null suites) $ putStrLn "Error: provide at least one test-suite name" >> exitFailure (sn, jId) <- getServiceAndJobId - Config <$> pure suites + Config <$> pure pn + <*> pure suites <*> pure sn <*> pure jId <*> pure (args `getArg` longOption "repo-token") <*> getGitInfo <*> defaultOr args (longOption "hpc-dir") (getHpcDir pn) - <*> defaultOr args (longOption "hpc-dir") getMixDir + <*> pure (args `getArg` longOption "mix-dir") <*> pure (if args `isPresent` longOption "partial-coverage" then PartialLines else FullLines) + <*> getStackProjects + <*> pure (args `isPresent` longOption "fetch-coverage") main :: IO () main = do @@ -84,12 +88,13 @@ PostSuccess u -> do let apiUrl = u ++ ".json" putStrLn $ "Job URL: " ++ apiUrl - -- wait 5 seconds until the page is available - threadDelay $ 5 * 1000 * 1000 - coverageResult <- readCoverageResult apiUrl - case coverageResult of - Just totalCov -> putStrLn $ "Coverage: " ++ show totalCov - Nothing -> putStrLn "Failed to read total coverage" + when (fetchCoverage conf) $ do + -- wait 5 seconds until the page is available + threadDelay $ 5 * 1000 * 1000 + coverageResult <- readCoverageResult apiUrl + case coverageResult of + Just totalCov -> putStrLn $ "Coverage: " ++ show totalCov + Nothing -> putStrLn "Failed to read total coverage" PostFailure msg -> do putStrLn $ "Error: " ++ msg exitFailure diff --git a/src/SHC/Api.hs b/src/SHC/Api.hs --- a/src/SHC/Api.hs +++ b/src/SHC/Api.hs @@ -15,6 +15,7 @@ where import Codec.Binary.UTF8.String (decode) +import Control.Exception (catch) import Data.Aeson (Value, encode) import Data.Aeson.Lens (key, _Double, _String) import qualified Data.ByteString as BS @@ -38,21 +39,28 @@ -> Value -- ^ The JSON object -> IO PostResult sendData conf url json = do - r <- post url [partFileRequestBody "json_file" fileName requestBody] + r <- postWith httpOptions url [partFileRequestBody "json_file" fileName requestBody] if r ^. responseStatus . statusCode == 200 then return $ readResponse r - else return . PostFailure $ - "Error: " ++ decode (BS.unpack $ r ^. responseStatus . statusMessage) + else return . PostFailure $ formatResponseError r where fileName = serviceName conf ++ "-" ++ jobId conf ++ ".json" requestBody = RequestBodyLBS $ encode json + httpOptions = defaults & checkStatus .~ Just noCheck + noCheck _ _ _ = Nothing readResponse :: Response LBS.ByteString -> PostResult readResponse r = case r ^? responseBody . key "error" . _String of - Just err -> PostFailure $ T.unpack err - Nothing -> case r ^? responseBody . key "url" . _String of - Just url -> PostSuccess $ T.unpack url - Nothing -> PostFailure "Error: malformed response body" + Just _ -> PostFailure $ formatResponseError r + Nothing -> case r ^? responseBody . key "url" . _String of + Just url -> PostSuccess $ T.unpack url + Nothing -> PostFailure "Error: malformed response body" + +formatResponseError :: Response LBS.ByteString -> String +formatResponseError r = + "Coveralls returned HTTP " ++ show (r ^. responseStatus . statusCode) ++ + " " ++ decode (BS.unpack $ r ^. responseStatus . statusMessage) ++ "\n" ++ + decode (LBS.unpack $ r ^. responseBody) -- | Read the coverage results from Coveralls.io. readCoverageResult :: String -> IO (Maybe Double) diff --git a/src/SHC/Coverage.hs b/src/SHC/Coverage.hs --- a/src/SHC/Coverage.hs +++ b/src/SHC/Coverage.hs @@ -19,23 +19,25 @@ #endif import Data.Aeson import Data.Aeson.Types () +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Digest.Pure.MD5 import Data.Function import Data.List +import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as M import SHC.Lix import SHC.Types import SHC.Utils import System.Exit (exitFailure) -import System.FilePath (()) +import System.FilePath ((), normalise) import Trace.Hpc.Mix import Trace.Hpc.Tix import Trace.Hpc.Util -type ModuleCoverageData = ( String -- file source code - , Mix -- module index data - , [Integer] -- tixs recorded by HPC +type ModuleCoverageData = ( BS.ByteString -- file source code + , Mix -- module index data + , [Integer] -- tixs recorded by HPC ) type TestSuiteCoverageData = M.Map FilePath ModuleCoverageData @@ -61,9 +63,6 @@ None -> Number 0 Irrelevant -> Null -readMix' :: Config -> TixModule -> IO Mix -readMix' conf tix = readMix [SHC.Types.mixDir conf] (Right tix) - -- | Generate Coveralls JSON formatted code coverage from HPC coverage data generateCoverallsFromTix :: Config -> IO Value generateCoverallsFromTix conf = do @@ -84,13 +83,18 @@ Nothing -> putStrLn ("Couldn't find the file " ++ tixPath) >> exitFailure Just (Tix tixs) -> do - mixs <- mapM (readMix' conf) tixs - let files = map filePath mixs - sources <- mapM readFile files - let coverageData = zip4 files sources mixs (map tixModuleTixs tixs) + coverageData <- mapM getCoverageData tixs let filteredCoverageData = filter sourceDirFilter coverageData return $ M.fromList $ map toFirstAndRest filteredCoverageData - where filePath (Mix fp _ _ _ _) = fp + where getCoverageData tixModule@(TixModule modName _ _ tixs) = do + let pkgKey = takeWhile (/= '/') modName + stackProj = + fromMaybe (error $ "readCoverageData/filePath/stackProj: couldn't find " ++ pkgKey) $ + find ((== pkgKey) . stackProjectKey) (stackProjects conf) + mix@(Mix origFp _ _ _ _) <- readMix [fromMaybe (stackProjectMixDir stackProj) (mixDir conf)] (Right tixModule) + let fp = normalise $ maybe id () (stackProjectPath stackProj) origFp + source <- BS.readFile fp + return (fp, source, mix, tixs) sourceDirFilter = not . matchAny excludeDirPatterns . fst4 excludeDirPatterns = [] -- XXX: for now @@ -110,15 +114,16 @@ coverageToJson :: LixConverter -> FilePath -> ModuleCoverageData -> Value coverageToJson converter path (source, mix, tixs) = object [ "name" .= path - , "source_digest" .= (show . md5 . LBS.pack) source + , "source_digest" .= (show . md5 . LBS.fromStrict) source , "coverage" .= coverage ] where coverage = toSimpleCoverage converter lineCount mixEntriesTixs - lineCount = length $ lines source + sourceLines = BS.lines source + lineCount = length sourceLines mixEntriesTixs = groupMixEntryTixs mixEntryTixs mixEntryTixs = zip3 mixEntries tixs (map getExprSource' mixEntries) Mix _ _ _ _ mixEntries = mix - getExprSource' = getExprSource $ lines source + getExprSource' = getExprSource $ map BS.unpack sourceLines mergeCoverageData :: [TestSuiteCoverageData] -> TestSuiteCoverageData mergeCoverageData = foldr1 $ M.unionWith mergeModule diff --git a/src/SHC/Stack.hs b/src/SHC/Stack.hs new file mode 100644 --- /dev/null +++ b/src/SHC/Stack.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: SHC.Stack +-- Copyright: (c) 2014-2015 Guillaume Nargeot, (c) 2015-2016 Felipe Lessa +-- License: BSD3 +-- Maintainer: Michele Lacchia +-- Stability: experimental +-- +-- Utility functions related to Stack. + +module SHC.Stack + where + +import Data.Version +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad (forM, guard) +import System.Directory (makeRelativeToCurrentDirectory) +import System.FilePath ((), equalFilePath) + +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Yaml as Y + +import SHC.Types +import SHC.Utils + + +stack :: [String] -> IO String +stack = readP "stack" + +-- | Verify that the required Stack is present. +checkStackVersion :: IO Bool +checkStackVersion = do + let lowerBound = Version [0,1,7,0] [] + stackVersion <- stack ["--numeric-version"] + return $ verifyVersion stackVersion lowerBound + +-- | Return the HPC data directory, given the package name. +getHpcDir :: String -> IO FilePath +getHpcDir package = ( package) <$> stack ["path", "--local-hpc-root"] + +-- | Return the HPC mix directory, where module data is stored. This +-- path needs to be prefixed with the project's path +-- (cf. 'stackProjectPath'). +getBaseMixDir :: IO FilePath +getBaseMixDir = ( "hpc") <$> stack ["path", "--dist-dir"] + +-- | Get relevant information from @stack query@. Used to find +-- package filepaths. +getStackQuery :: IO StackQuery +getStackQuery = (Y.decodeEither' . BS8.pack <$> stack ["query"]) >>= either err return + where err = fail . (++) "getStackQuery: Couldn't decode the result of 'stack query' as YAML: " . show + +-- | Get the key that GHC uses for the given package. +getProjectKey :: String -> IO String +getProjectKey pkgName = stack ["exec", "--", "ghc-pkg", "field", pkgName, "key", "--simple-output"] + +-- | Get the Stack info needed to find project files. +getStackProjects :: IO [StackProject] +getStackProjects = do + sq <- getStackQuery + baseMixDir <- getBaseMixDir + forM (stackQueryLocals sq) $ \(pkgName, filepath) -> do + relfp <- makeRelativeToCurrentDirectory filepath + let mpath = guard (not $ relfp `equalFilePath` ".") >> Just relfp + key <- getProjectKey pkgName + return + StackProject + { stackProjectName = pkgName + , stackProjectPath = mpath + , stackProjectKey = key + , stackProjectMixDir = maybe id () mpath baseMixDir + } diff --git a/src/SHC/Types.hs b/src/SHC/Types.hs --- a/src/SHC/Types.hs +++ b/src/SHC/Types.hs @@ -1,12 +1,19 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module SHC.Types where +import Control.Monad (forM) import Data.Aeson +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T import Trace.Hpc.Mix +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif + data ConversionType = FullLines | PartialLines deriving (Show, Eq) @@ -30,14 +37,17 @@ deriving (Show) data Config = Config - { suitesName :: [String] - , serviceName :: String - , jobId :: String - , repoToken :: Maybe String - , gitInfo :: GitInfo - , hpcDir :: FilePath - , mixDir :: FilePath - , conversion :: ConversionType + { packageName :: String + , suitesName :: [String] + , serviceName :: String + , jobId :: String + , repoToken :: Maybe String + , gitInfo :: GitInfo + , hpcDir :: FilePath + , mixDir :: Maybe FilePath + , conversion :: ConversionType + , stackProjects :: [StackProject] + , fetchCoverage :: Bool } data GitInfo = GitInfo @@ -79,3 +89,36 @@ toJSON r = object [ "name" .= name r , "url" .= url r ] + +-- | Data returned by the @stack query@ command. +data StackQuery = + StackQuery + { stackQueryLocals :: [(String, FilePath)] + -- ^ A list of pairs of @(package-name, filepath)@, where the + -- @filepath@ is the absolute 'FilePath' where @package-name@ is + -- located. + } deriving (Show) + +instance FromJSON StackQuery where + parseJSON = withObject "StackQuery" $ \o -> StackQuery <$> (o .: "locals" >>= parseLocals) + where + parseLocals = + withObject "StackQuery/locals" $ \o -> + forM (HM.toList o) $ \(pkgName, val) -> do + filepath <- withObject "StackQuery/locals/package" (.: "path") val + return (T.unpack pkgName, filepath) + + +-- | Information we've collected about a stack project. +data StackProject = + StackProject + { stackProjectName :: String + -- ^ The name of this project. + , stackProjectPath :: Maybe FilePath + -- ^ Path of the project relative to current path. @Nothing@ iff + -- the project's path is the current path. + , stackProjectKey :: String + -- ^ Key that @ghc-pkg@ uses for this project. + , stackProjectMixDir :: FilePath + -- ^ The project's mix dir (cf. 'getMixDir'). + } deriving (Show) diff --git a/src/SHC/Utils.hs b/src/SHC/Utils.hs --- a/src/SHC/Utils.hs +++ b/src/SHC/Utils.hs @@ -19,7 +19,6 @@ import Control.Applicative ((<$>), (<*>)) #endif import Text.ParserCombinators.ReadP -import System.FilePath (()) import System.Process (readProcess) import SHC.Types @@ -31,9 +30,6 @@ git :: [String] -> IO String git = readP "git" -stack :: [String] -> IO String -stack = readP "stack" - -- | Get information about the Git repo in the current directory. getGitInfo :: IO GitInfo getGitInfo = GitInfo <$> headRef <*> branchName <*> getRemotes @@ -46,7 +42,7 @@ branchName = git ["rev-parse", "--abbrev-ref", "HEAD"] getRemotes :: IO [Remote] -getRemotes = nubBy ((==) `on` name) <$> parseRemotes <$> git ["remote", "-v"] +getRemotes = nubBy ((==) `on` name) . parseRemotes <$> git ["remote", "-v"] where parseRemotes :: String -> [Remote] parseRemotes input = do line <- lines input @@ -54,27 +50,12 @@ guard $ length fields >= 2 return $ Remote (head fields) (fields !! 1) --- | Verify that the required Stack is present. -checkStackVersion :: IO Bool -checkStackVersion = do - let lowerBound = Version [0,1,7,0] [] - stackVersion <- stack ["--numeric-version"] - return $ verifyVersion stackVersion lowerBound - -- | Check whether a string is a version and if it is -- greater than or equal to a specified version. verifyVersion :: String -> Version -> Bool verifyVersion ver lowerBound = let parses = readP_to_S parseVersion ver in not (null parses) && (lowerBound <= fst (last parses)) - --- | Return the HPC data directory, given the package name. -getHpcDir :: String -> IO FilePath -getHpcDir package = ( package) <$> stack ["path", "--local-hpc-root"] - --- | Return the HPC mix directory, where module data is stored. -getMixDir :: IO FilePath -getMixDir = ( "hpc") <$> stack ["path", "--dist-dir"] fst3 :: (a, b, c) -> a fst3 (x, _, _) = x diff --git a/stack-hpc-coveralls.cabal b/stack-hpc-coveralls.cabal --- a/stack-hpc-coveralls.cabal +++ b/stack-hpc-coveralls.cabal @@ -1,5 +1,5 @@ name: stack-hpc-coveralls -version: 0.0.3.0 +version: 0.0.4.0 synopsis: Initial project template from stack description: Please see README.md homepage: http://github.com/rubik/stack-hpc-coveralls @@ -22,20 +22,24 @@ SHC.Utils SHC.Lix SHC.Api - build-depends: base >=4.7 && <5 - , hpc >=0.6 - , filepath >=1.3 - , process >=1.2 - , pureMD5 >=2.1 - , containers >=0.5 - , aeson >=0.8 - , bytestring >=0.10 - , utf8-string >=1 - , text >=1.2 - , wreq >=0.3 - , http-client >=0.4 - , lens >=4.7 - , lens-aeson >=1.0 + SHC.Stack + build-depends: base >=4.7 && <5 + , hpc >=0.6 + , directory >=1.0 + , filepath >=1.3 + , process >=1.2 + , pureMD5 >=2.1 + , containers >=0.5 + , aeson >=0.8 + , bytestring >=0.10 + , unordered-containers >=0.2 + , utf8-string >=1 + , text >=1.2 + , wreq >=0.3 + , http-client >=0.4 + , lens >=4.7 + , lens-aeson >=1.0 + , yaml >=0.8 default-language: Haskell2010 executable shc diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-3.11 +resolver: nightly-2016-06-15 # Local packages, usually specified by relative directory name packages: