module Testlib.XML where

import qualified Data.Array as Array
import Data.Fixed
import Data.Time
import Testlib.Types
import qualified Text.Regex.Base as Regex
import qualified Text.Regex.TDFA.String as Regex
import Text.XML.Light
import Prelude

saveXMLReport :: TestSuiteReport -> FilePath -> IO ()
saveXMLReport :: TestSuiteReport -> FilePath -> IO ()
saveXMLReport TestSuiteReport
report FilePath
output =
  FilePath -> FilePath -> IO ()
writeFile FilePath
output (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Element -> FilePath
showTopElement (Element -> FilePath) -> Element -> FilePath
forall a b. (a -> b) -> a -> b
$ TestSuiteReport -> Element
xmlReport TestSuiteReport
report

xmlReport :: TestSuiteReport -> Element
xmlReport :: TestSuiteReport -> Element
xmlReport TestSuiteReport
report =
  FilePath -> (Attr, Element) -> Element
forall t. Node t => FilePath -> t -> Element
unode
    FilePath
"testsuites"
    ( QName -> FilePath -> Attr
Attr (FilePath -> QName
unqual FilePath
"name") FilePath
"wire-server",
      Element
testSuiteElements
    )
  where
    testSuiteElements :: Element
testSuiteElements =
      FilePath -> ([Attr], [Element]) -> Element
forall t. Node t => FilePath -> t -> Element
unode
        FilePath
"testsuite"
        ( [Attr]
attrs,
          (TestCaseReport -> Element) -> [TestCaseReport] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map TestCaseReport -> Element
encodeTestCase TestSuiteReport
report.cases
        )
    attrs :: [Attr]
attrs =
      [ QName -> FilePath -> Attr
Attr (FilePath -> QName
unqual FilePath
"name") FilePath
"integration",
        QName -> FilePath -> Attr
Attr (FilePath -> QName
unqual FilePath
"tests") (FilePath -> Attr) -> FilePath -> Attr
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ [TestCaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TestSuiteReport
report.cases,
        QName -> FilePath -> Attr
Attr (FilePath -> QName
unqual FilePath
"failures") (FilePath -> Attr) -> FilePath -> Attr
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ [TestCaseReport] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TestCaseReport] -> Int) -> [TestCaseReport] -> Int
forall a b. (a -> b) -> a -> b
$ (TestCaseReport -> Bool) -> [TestCaseReport] -> [TestCaseReport]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TestCaseReport
testCase -> TestCaseReport
testCase.result TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
/= TestResult
TestSuccess) TestSuiteReport
report.cases,
        QName -> FilePath -> Attr
Attr (FilePath -> QName
unqual FilePath
"time") (FilePath -> Attr) -> FilePath -> Attr
forall a b. (a -> b) -> a -> b
$ Bool -> Fixed E12 -> FilePath
forall {k} (a :: k). HasResolution a => Bool -> Fixed a -> FilePath
showFixed Bool
True (Fixed E12 -> FilePath) -> Fixed E12 -> FilePath
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Fixed E12
nominalDiffTimeToSeconds (NominalDiffTime -> Fixed E12) -> NominalDiffTime -> Fixed E12
forall a b. (a -> b) -> a -> b
$ [NominalDiffTime] -> NominalDiffTime
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([NominalDiffTime] -> NominalDiffTime)
-> [NominalDiffTime] -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ (TestCaseReport -> NominalDiffTime)
-> [TestCaseReport] -> [NominalDiffTime]
forall a b. (a -> b) -> [a] -> [b]
map (.time) TestSuiteReport
report.cases
      ]

encodeTestCase :: TestCaseReport -> Element
encodeTestCase :: TestCaseReport -> Element
encodeTestCase TestCaseReport {FilePath
NominalDiffTime
TestResult
name :: FilePath
result :: TestResult
time :: NominalDiffTime
$sel:name:TestCaseReport :: TestCaseReport -> FilePath
$sel:result:TestCaseReport :: TestCaseReport -> TestResult
$sel:time:TestCaseReport :: TestCaseReport -> NominalDiffTime
..} =
  FilePath -> ([Attr], [Element]) -> Element
forall t. Node t => FilePath -> t -> Element
unode FilePath
"testcase" ([Attr]
attrs, [Element]
content)
  where
    attrs :: [Attr]
attrs =
      [ QName -> FilePath -> Attr
Attr (FilePath -> QName
unqual FilePath
"name") FilePath
name,
        QName -> FilePath -> Attr
Attr (FilePath -> QName
unqual FilePath
"time") (Bool -> Fixed E12 -> FilePath
forall {k} (a :: k). HasResolution a => Bool -> Fixed a -> FilePath
showFixed Bool
True (NominalDiffTime -> Fixed E12
nominalDiffTimeToSeconds NominalDiffTime
time))
      ]
    content :: [Element]
content = case TestResult
result of
      TestResult
TestSuccess -> []
      TestFailure FilePath
msg -> [FilePath -> Element
failure FilePath
msg]
    failure :: FilePath -> Element
failure FilePath
msg = FilePath -> CData -> Element
forall t. Node t => FilePath -> t -> Element
unode FilePath
"failure" (CData
blank_cdata {cdData = dropConsoleFormatting msg})

    -- Drops ANSI control characters which might be used to set colors.
    -- Including these breaks XML, there is not much point encoding them.
    dropConsoleFormatting :: [a] -> [a]
dropConsoleFormatting [a]
input =
      let regex :: Regex
regex = FilePath -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
Regex.makeRegex FilePath
"\x1b\\[[0-9;]*[mGKHF]" :: Regex.Regex
          matches :: [MatchArray]
matches = Regex -> [a] -> [MatchArray]
forall regex source.
RegexLike regex source =>
regex -> source -> [MatchArray]
Regex.matchAll Regex
regex [a]
input
          dropMatch :: (Int, Int) -> [a] -> [a]
dropMatch (Int
offset, Int
len) [a]
input' =
            let ([a]
begining, [a]
rest) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
offset [a]
input'
                ([a]
_, [a]
end) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len [a]
rest
             in [a]
begining [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
end
          matchTuples :: [(Int, Int)]
matchTuples = (MatchArray -> (Int, Int)) -> [MatchArray] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (MatchArray -> Int -> (Int, Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
0) [MatchArray]
matches
       in ((Int, Int) -> [a] -> [a]) -> [a] -> [(Int, Int)] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int) -> [a] -> [a]
forall {a}. (Int, Int) -> [a] -> [a]
dropMatch [a]
input [(Int, Int)]
matchTuples