-
Notifications
You must be signed in to change notification settings - Fork 20
/
HpcCoverallsMain.hs
84 lines (78 loc) · 3.58 KB
/
HpcCoverallsMain.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
module Main where
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.List
import Data.Maybe hiding (listToMaybe)
import HpcCoverallsCmdLine
import System.Console.CmdArgs
import System.Environment (getEnv, getEnvironment)
import System.Exit (exitFailure)
import Trace.Hpc.Coveralls
import Trace.Hpc.Coveralls.Cabal
import Trace.Hpc.Coveralls.Config (Config(Config, cabalFile, serviceName))
import Trace.Hpc.Coveralls.Curl
import Trace.Hpc.Coveralls.GitInfo (getGitInfo)
import Trace.Hpc.Coveralls.Util
urlApiV1 :: String
urlApiV1 = "https://coveralls.io/api/v1/jobs"
getServiceAndJobID :: IO (String, String)
getServiceAndJobID = do
env <- getEnvironment
case 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")),
("BUILDKITE", ("buildkite", "BUILDKITE_BUILD_NUMBER"))]
writeJson :: String -> Value -> IO ()
writeJson filePath = BSL.writeFile filePath . encode
getConfig :: HpcCoverallsArgs -> Maybe Config
getConfig hca = Config
(optExcludeDirs hca)
(optCoverageMode hca)
(optCabalFile hca)
(optServiceName hca)
(optRepoToken hca)
<$> listToMaybe (argTestSuites hca)
main :: IO ()
main = do
hca <- cmdArgs hpcCoverallsArgs
case getConfig hca of
Nothing -> putStrLn "Please specify a target test suite name"
Just config -> do
(defaultServiceName, jobId) <- getServiceAndJobID
let sn = fromMaybe defaultServiceName (serviceName config)
gitInfo <- getGitInfo
mPkgNameVer <- case cabalFile config of
Just cabalFilePath -> getPackageNameVersion cabalFilePath
Nothing -> currDirPkgNameVer
gitInfo <- getGitInfo
coverallsJson <- generateCoverallsFromTix sn jobId gitInfo config mPkgNameVer
when (optDisplayReport hca) $ BSL.putStrLn $ encode coverallsJson
let filePath = sn ++ "-" ++ jobId ++ ".json"
writeJson filePath coverallsJson
unless (optDontSend hca) $ do
response <- postJson filePath urlApiV1 (optCurlVerbose hca)
case response of
PostSuccess url -> do
putStrLn ("URL: " ++ url)
-- wait 10 seconds until the page is available
threadDelay (10 * 1000 * 1000)
coverageResult <- readCoverageResult url (optCurlVerbose hca)
case coverageResult of
Just totalCoverage -> putStrLn ("Coverage: " ++ totalCoverage)
Nothing -> putStrLn "Failed to read total coverage"
PostFailure msg -> do
putStrLn ("Error: " ++ msg)
putStrLn ("You can get support at " ++ gitterUrl)
exitFailure
where gitterUrl = "https://gitter.im/guillaume-nargeot/hpc-coveralls"