src/JUnit.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

module JUnit (
    writeJUnitReport,
) where

import Control.Monad

import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BC
import Data.Function
import Data.List.NonEmpty qualified as NE
import Data.Scientific
import Data.Text qualified as T
import Data.Text.Encoding

import System.Directory
import System.FilePath
import System.IO

import Run
import Script.Var


showTime :: Scientific -> B.ByteString
showTime = BC.pack . formatScientific Fixed Nothing

writeJUnitReport :: FilePath -> Report -> IO ()
writeJUnitReport path Report {..} = do
    createDirectoryIfMissing True $ takeDirectory path
    withFile path WriteMode $ \h -> do
        B.hPutStr h $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
        B.hPutStr h $ "<testsuites time=\"" <> showTime reportTotalTime <> "\">\n"
        forM_ (NE.groupBy ((==) `on` (testNameModule . reportTestName)) reportTests) $ \grp -> do
            B.hPutStr h $ "<testsuite name=\"" <> encodeUtf8 (textModuleName $ testNameModule $ reportTestName $ NE.head grp) <> "\" time=\"" <> showTime (sum $ map reportTime $ NE.toList grp) <> "\">"
            forM_ grp $ \SingleTestReport {..} -> do
                B.hPutStr h $ B.concat
                    [ "<testcase name=\"", encodeUtf8 (testNameBase reportTestName), "\""
                    , " classname=\"", encodeUtf8 (textModuleName $ testNameModule reportTestName), "\""
                    , " time=\"", showTime reportTime, "\">"
                    , "<system-out>"
                    , encodeUtf8 $ escape reportOutput
                    , "</system-out>"
                    , case reportTestFailed of
                        Nothing -> do
                            ""
                        Just Failed -> do
                            "<failure message=\"Test failed\">" <> encodeUtf8 (escape reportOutputError) <> "</failure>"
                        Just (ProcessCrashed _) -> do
                            "<error message=\"Process crashed\">" <> encodeUtf8 (escape reportOutputError) <> "</error>"
                    , "</testcase>"
                    ]

            B.hPutStr h $ "</testsuite>"
        B.hPutStr h $ "</testsuites>\n"

  where
    escape = T.concatMap $ \case
        '&' -> "&amp;"
        '<' -> "&lt;"
        '>' -> "&gt;"
        c -> T.singleton c