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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (forM_)
import Control.Arrow.ListArrow (runLA)
import Data.Either.Utils (maybeToEither)
import Data.List (find)
import Data.List.Safe (head, tail)
import Data.List.Utils (split)
import Data.Tree.NTree.TypeDefs (NTree(..))
import Prelude hiding (head, tail)
import System.Console.CmdArgs.Implicit (Data, Typeable, cmdArgs)
import System.Directory (createDirectoryIfMissing)
import System.Exit (exitFailure)
import System.FilePath (FilePath, (</>), takeDirectory)
import qualified Text.XML.HXT.Arrow.ReadDocument as XML
import Text.XML.HXT.DOM.QualifiedName (localPart)
import Text.XML.HXT.DOM.TypeDefs (XNode(..), XmlTree)
import Text.XML.HXT.XPath.XPathEval (getXPath, getXPathSubTrees)
data Args = Args
{ testlog :: FilePath
, destdir :: FilePath
} deriving (Data, Typeable)
data ReportFile = ReportFile
{ content :: String
, filename :: FilePath
} deriving (Show)
main :: IO ()
main = do
Args {testlog, destdir} <- cmdArgs $ Args {testlog = "", destdir = ""}
if testlog == ""
then putStrLn noTestlogError >> exitFailure
else do
fileContents <- readFile testlog
let xmlTrees = runLA XML.xreadDoc fileContents
let rootTree = find isRoot xmlTrees
case rootTree of
Nothing -> do
putStrLn "Invalid XML format for testlog."
exitFailure
Just tree -> do
let reportFiles = generateReportFiles tree
case reportFiles of
Right reports ->
forM_ reports $ \ReportFile {content, filename} -> do
putStrLn $ concat ["Creating ", show $ destdir </> filename]
createDirectoryIfMissing
True
(destdir </> takeDirectory filename)
writeFile (destdir </> filename) content
Left err -> do
putStrLn err
exitFailure
generateReportFiles :: XmlTree -> Either String [ReportFile]
generateReportFiles doc =
let testSuites = getXPath "/testsuites/testsuite" doc
in concat <$> sequence (reportsForTestCase <$> testSuites)
reportsForTestCase :: XmlTree -> Either String [ReportFile]
reportsForTestCase testSuite = do
caseName <-
extractAttr =<<
maybeToEither
"Couldn't find testcase name."
(head (getXPathSubTrees "/testsuite/testcase/@name" testSuite))
let coverageOutputDirectory = takeDirectory caseName
testOutput <-
extractText =<<
maybeToEither
"Couldn't find system output."
(head (getXPathSubTrees "/testsuite/system-out" testSuite))
htmlPortion <-
maybeToEither
("Couldn't find HTML report section in test case " ++ caseName ++ ".")
(head =<< tail (split testOutputSeparator testOutput))
let coverageReportPartXmlTrees = runLA XML.hreadDoc htmlPortion
traverse
(coveragePartToReportFile coverageOutputDirectory)
coverageReportPartXmlTrees
coveragePartToReportFile :: FilePath -> XmlTree -> Either String ReportFile
coveragePartToReportFile parentDirectory reportPart = do
filename <-
extractAttr =<<
maybeToEither
"Couldn't find report part name."
(head (getXPathSubTrees "/coverage-report-part/@name" reportPart))
content <- extractText reportPart
return $
ReportFile
{ content = content
, filename = "coverage-reports" </> parentDirectory </> filename
}
noTestlogError :: String
noTestlogError =
unlines
[ "ERROR: You must specify the testlog XML file location with --testlog."
, "It is found inside the bazel-testlog, in the respective"
, "folder for the test you're interested in."
, "This must be after having run 'bazel coverage'."
]
isRoot :: XmlTree -> Bool
isRoot tree =
case tree of
NTree (XTag name _) _ -> localPart name == "testsuites"
_ -> False
extractAttr :: XmlTree -> Either String String
extractAttr tree =
case tree of
NTree (XAttr _) [NTree (XText value) []] -> pure value
_ -> Left "Couldn't extract attribute from test XML."
extractText :: XmlTree -> Either String String
extractText tree =
let treeToText :: XmlTree -> String -> String
treeToText textTree acc =
case textTree of
(NTree (XText value) _) -> acc ++ value
_ -> ""
in case tree of
NTree (XTag _ _) textTree -> pure $ foldr treeToText "" textTree
_ -> Left "Couldn't extract text from test XML."
testOutputSeparator :: String
testOutputSeparator = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
|
