junit-xml (empty) → 0.1.0.0
raw patch · 7 files changed
+577/−0 lines, 7 filesdep +basedep +junit-xmldep +tasty
Dependencies added: base, junit-xml, tasty, tasty-golden, text, xml-conduit
Files
- CHANGELOG.md +3/−0
- LICENSE +29/−0
- README.md +3/−0
- junit-xml.cabal +57/−0
- src/Text/XML/JUnit.hs +436/−0
- test/Main.hs +45/−0
- test/sample-report.xml +4/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++- Initial implementation.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020, Jasper Woudenberg+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+# junit-xml++A library for producing JUnit style XML reports in Haskell, for consumption by CI platforms like Jenkins.
+ junit-xml.cabal view
@@ -0,0 +1,57 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: d9e612dfa72967ec95cd316447a563846b10fe23377c8b6bd3410890c64ab56d++name: junit-xml+version: 0.1.0.0+synopsis: Producing JUnit-style XML test reports.+description: Please see the README at <https://github.com/jwoudenberg/junit-xml>.+category: Web+homepage: https://github.com/jwoudenberg/junit-xml#readme+bug-reports: https://github.com/jwoudenberg/junit-xml/issues+author: Jasper Woudenberg+maintainer: mail@jasperwoudenberg.com+copyright: 2020 Jasper Woudenberg+license: BSD3+license-file: LICENSE+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md+data-files:+ test/sample-report.xml++source-repository head+ type: git+ location: https://github.com/jwoudenberg/junit-xml++library+ exposed-modules:+ Text.XML.JUnit+ other-modules:+ Paths_junit_xml+ hs-source-dirs:+ src+ build-depends:+ base >=4.10.1.0 && <5+ , text+ , xml-conduit >=1.5.0 && <1.10+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_junit_xml+ hs-source-dirs:+ test+ build-depends:+ base+ , junit-xml+ , tasty >=1.1 && <1.3+ , tasty-golden >=2.3 && <2.4+ default-language: Haskell2010
+ src/Text/XML/JUnit.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- A module for producing JUnit style XML reports, for consumption by CI+-- platforms like Jenkins.+-- Please see the README at <https://github.com/jwoudenberg/junit-xml>.+module Text.XML.JUnit+ ( -- * Writing test reports+ writeXmlReport,++ -- * Test report constructors+ passed,+ skipped,+ failed,+ errored,+ inSuite,++ -- * Adding test report details+ stdout,+ stderr,+ time,+ failureMessage,+ failureStackTrace,+ errorMessage,+ errorStackTrace,++ -- * Helper types+ TestReport,+ TestSuite,+ )+where++import Data.Function ((&))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromMaybe)+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified Data.Text.Lazy.IO+import GHC.Exts (fromList)+import qualified Text.XML as XML++-- | This function writes an xml report to the provided path.+--+-- @+-- import Data.Function ((&))+--+-- writeXmlReport "report.xml"+-- [ 'passed' "A passing test"+-- & 'inSuite' "Test suite"+-- , 'failed' "A failing test"+-- & 'inSuite' "Test suite"+-- ]+-- @+writeXmlReport :: FilePath -> [TestSuite] -> IO ()+writeXmlReport out =+ Data.Text.Lazy.IO.writeFile out . XML.renderText XML.def . encode++-- | The report for a single test case.+data TestReport outcome where+ TestReport ::+ Outcome outcome =>+ { testName' :: T.Text,+ outcome' :: outcome,+ stdout' :: Maybe T.Text,+ stderr' :: Maybe T.Text,+ time' :: Maybe Double+ } ->+ TestReport+ outcome++-- | A test report annotated with the test suite it is part of.+data TestSuite+ = TestSuite+ { suiteName :: T.Text,+ testReport :: XML.Element,+ counts :: Counts+ }++-- | Wrap a test report in a suite, allowing it to be added to the list of+-- reports passed to 'writeXmlReports'.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ 'passed' "Passed test"+-- & inSuite "Some test suite"+-- ]+--+-- @+inSuite :: T.Text -> TestReport outcome -> TestSuite+inSuite name test@TestReport {outcome', time'} =+ TestSuite+ { suiteName = name,+ testReport = encodeTestCase test,+ counts = (outcomeCounter outcome') {cumTime = fromMaybe 0 time'}+ }++mapTest :: (a -> a) -> TestReport a -> TestReport a+mapTest f test = test {outcome' = f (outcome' test)}++-- | Add the stdout produced running a test to the report for that test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ 'passed' "A passing test"+-- & stdout "Test ran succesfully!"+-- & 'inSuite' "Test suite"+-- ]+-- @+stdout :: T.Text -> TestReport outcome -> TestReport outcome+stdout log test = test {stdout' = Just log}++-- | Add the stderr produced running a test to the report for that test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ 'failed' "A failing test"+-- & stderr "Expected 4, but got 2."+-- & 'inSuite' "Test suite"+-- ]+-- @+stderr :: T.Text -> TestReport outcome -> TestReport outcome+stderr log test = test {stderr' = Just log}++-- | Add the running time of a test to the report for that test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ 'passed' "A passing test"+-- & time 0.003+-- & 'inSuite' "Test suite"+-- ]+-- @+time :: Double -> TestReport outcome -> TestReport outcome+time seconds test = test {time' = Just seconds}++-- | Create a report for a passing test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ passed "A passing test"+-- & 'stdout' "Test ran succesfully!"+-- & 'stderr' "Warning: don't overcook the vegetables!"+-- & 'time' 0.003+-- & 'inSuite' "Test suite"+-- ]+-- @+passed :: T.Text -> TestReport Passed+passed name =+ TestReport+ { testName' = name,+ outcome' = Passed,+ stdout' = Nothing,+ stderr' = Nothing,+ time' = Nothing+ }++-- | Create a report for a skipped test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ skipped "A skipped test"+-- & 'inSuite' "Test suite"+-- ]+-- @+skipped :: T.Text -> TestReport Skipped+skipped name =+ TestReport+ { testName' = name,+ outcome' = Skipped,+ stdout' = Nothing,+ stderr' = Nothing,+ time' = Nothing+ }++-- | Create a report for a failed test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ failed "A failing test"+-- & 'stdout' "Running test..."+-- & 'stderr' "Test failed: expected 3 slices of pizza but got one."+-- & 'failureMessage' "Not enough pizza"+-- & 'failureStackTrace' ["Pizza", "Pizzeria", "Italy"]+-- & 'time' 0.08+-- & 'inSuite' "Test suite"+-- ]+-- @+failed :: T.Text -> TestReport Failed+failed name =+ TestReport+ { testName' = name,+ outcome' = Failure Nothing [],+ stdout' = Nothing,+ stderr' = Nothing,+ time' = Nothing+ }++-- | Create a report for a test that threw an error.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ errored "A test that threw an error"+-- & 'stdout' "Running test..."+-- & 'stderr' "Unexpected exception: BedTime"+-- & 'errorMessage' "Operation canceled due to BedTimeOut"+-- & 'errorStackTrace' ["Bed", "Sleep", "Night"]+-- & 'time' 0.08+-- & 'inSuite' "Test suite"+-- ]+-- @+errored :: T.Text -> TestReport Errored+errored name =+ TestReport+ { testName' = name,+ outcome' = Error Nothing [],+ stdout' = Nothing,+ stderr' = Nothing,+ time' = Nothing+ }++class Outcome a where++ outcomeToXML :: a -> Maybe XML.Element++ outcomeCounter :: a -> Counts++data Passed = Passed++instance Outcome Passed where++ outcomeToXML _ = Nothing++ outcomeCounter _ = mempty {cumTests = 1}++data Skipped = Skipped++instance Outcome Skipped where++ outcomeToXML _ = Just $ XML.Element "skipped" mempty []++ outcomeCounter _ = mempty {cumSkipped = 1, cumTests = 1}++data Failed+ = Failure+ { -- Warning: newlines in the failure message will look like spaces in the+ -- Jenkins UI!+ failureMessage' :: Maybe T.Text,+ failureStackTrace' :: [T.Text]+ }++instance Outcome Failed where++ outcomeToXML = Just . encodeFailure++ outcomeCounter _ = mempty {cumFailed = 1, cumTests = 1}++-- | Add an error message to the report of a failed test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ failed "A failing test"+-- & failureMessage "Laundromat exceeds noise tolerance."+-- & 'inSuite' "Test suite"+-- ]+-- @+failureMessage :: T.Text -> TestReport Failed -> TestReport Failed+failureMessage msg test =+ mapTest (\outcome -> outcome {failureMessage' = Just msg}) test++-- | Add a stack trace to the report of a failed test.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ failed "A failing test"+-- & failureStackTrace ["AnkleClass", "LegClass", "LimbClass"]+-- & 'inSuite' "Test suite"+-- ]+-- @+failureStackTrace :: [T.Text] -> TestReport Failed -> TestReport Failed+failureStackTrace trace test =+ mapTest (\outcome -> outcome {failureStackTrace' = trace}) test++data Errored+ = Error+ { -- Warning: newlines in the failure message will look like spaces in the+ -- Jenkins UI!+ errorMessage' :: Maybe T.Text,+ errorStackTrace' :: [T.Text]+ }++instance Outcome Errored where++ outcomeToXML = Just . encodeError++ outcomeCounter _ = mempty {cumErrored = 1, cumTests = 1}++-- | Add an error message to the report for a test that threw an exception.+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ errored "A test that threw an error"+-- & errorMessage "TooMuchNetflixException"+-- & 'inSuite' "Test suite"+-- ]+-- @+errorMessage :: T.Text -> TestReport Errored -> TestReport Errored+errorMessage msg test =+ mapTest (\outcome -> outcome {errorMessage' = Just msg}) test++-- | Add a stack trace to a report for a test that threw an exception+--+-- @+-- import Data.Function ((&))+--+-- 'writeXmlReport' "report.xml"+-- [ errored "A test that threw an error"+-- & errorStackTrace ["at closeCurtain line 3", "at goToSleep line 8"]+-- & 'inSuite' "Test suite"+-- ]+-- @+errorStackTrace :: [T.Text] -> TestReport Errored -> TestReport Errored+errorStackTrace trace test =+ mapTest (\outcome -> outcome {errorStackTrace' = trace}) test++data Counts+ = Counts+ { cumTests :: Int,+ cumFailed :: Int,+ cumErrored :: Int,+ cumSkipped :: Int,+ cumTime :: Double+ }++instance Semigroup Counts where+ c1 <> c2 = Counts+ { cumTests = cumTests c1 + cumTests c2,+ cumFailed = cumFailed c1 + cumFailed c2,+ cumErrored = cumErrored c1 + cumErrored c2,+ cumSkipped = cumSkipped c1 + cumSkipped c2,+ cumTime = cumTime c1 + cumTime c2+ }++instance Monoid Counts where+ mempty = Counts 0 0 0 0 0++encode :: [TestSuite] -> XML.Document+encode suites =+ XML.Document prologue element []+ where+ prologue = XML.Prologue [] Nothing []+ (totalCounts, suiteElements) =+ foldMap+ (fmap (pure . XML.NodeElement) . encodeSuite)+ (NonEmpty.groupAllWith suiteName suites)+ element =+ XML.Element+ "testsuites"+ (fromList (countAttributes totalCounts))+ suiteElements++encodeSuite :: NonEmpty.NonEmpty TestSuite -> (Counts, XML.Element)+encodeSuite suite =+ (suiteCounts, element)+ where+ suiteCounts = foldMap counts suite+ element =+ XML.Element+ "testsuite"+ (fromList $ ("name", suiteName (NonEmpty.head suite)) : countAttributes suiteCounts)+ (NonEmpty.toList (XML.NodeElement . testReport <$> suite))++encodeTestCase :: TestReport a -> XML.Element+encodeTestCase TestReport {testName', outcome', stdout', stderr', time'} =+ XML.Element "testcase" attributes children+ where+ attributes =+ fromList $+ catMaybes+ [ Just $ ("name", testName'),+ (,) "time" . T.pack . show <$> time'+ ]+ children =+ XML.NodeElement+ <$> catMaybes+ [ outcomeToXML outcome',+ XML.Element "system-out" mempty . pure . XML.NodeContent <$> stdout',+ XML.Element "system-err" mempty . pure . XML.NodeContent <$> stderr'+ ]++encodeFailure :: Failed -> XML.Element+encodeFailure failure =+ XML.Element+ "failure"+ (maybe mempty (\v -> fromList [("message", v)]) (failureMessage' failure))+ [XML.NodeContent (T.unlines (failureStackTrace' failure))]++encodeError :: Errored -> XML.Element+encodeError err =+ XML.Element+ "error"+ (maybe mempty (\v -> fromList [("message", v)]) (errorMessage' err))+ [XML.NodeContent (T.unlines (errorStackTrace' err))]++countAttributes :: Counts -> [(XML.Name, T.Text)]+countAttributes counts =+ [ ("tests", T.pack (show (cumTests counts))),+ ("failures", T.pack (show (cumFailed counts))),+ ("errors", T.pack (show (cumErrored counts))),+ ("skipped", T.pack (show (cumSkipped counts))),+ ("time", T.pack (show (cumTime counts)))+ ]
+ test/Main.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Main+ ( main,+ )+where++import Data.Function ((&))+import Test.Tasty+import Test.Tasty.Golden as Golden+import Text.XML.JUnit++main = defaultMain tests++tests :: TestTree+tests =+ Golden.goldenVsFile+ "Generate sample XML"+ "test/sample-report.xml"+ out+ (writeXmlReport out suites)+ where+ out = "/tmp/junit-xml-haskell-test.xml"+ suites =+ [ passed "Passed test"+ & stdout "passing stdout"+ & time 0.3+ & inSuite "suite 1",+ skipped "Skipped test"+ & inSuite "suite 1",+ failed "Failed test"+ & stdout "failing stdout"+ & stderr "failing stderr"+ & time 0.2+ & failureMessage "failing message"+ & failureStackTrace ["frame1", "frame2"]+ & inSuite "suite 1",+ errored "Errored test"+ & stdout "errored stdout"+ & stderr "errored stderr"+ & time 0.1+ & errorMessage "errored message"+ & errorStackTrace ["single error frame"]+ & inSuite "suite 2"+ ]
+ test/sample-report.xml view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?><testsuites errors="1" failures="1" skipped="1" tests="4" time="0.6"><testsuite errors="0" failures="1" name="suite 1" skipped="1" tests="3" time="0.5"><testcase name="Passed test" time="0.3"><system-out>passing stdout</system-out></testcase><testcase name="Skipped test"><skipped/></testcase><testcase name="Failed test" time="0.2"><failure message="failing message">frame1+frame2+</failure><system-out>failing stdout</system-out><system-err>failing stderr</system-err></testcase></testsuite><testsuite errors="1" failures="0" name="suite 2" skipped="0" tests="1" time="0.1"><testcase name="Errored test" time="0.1"><error message="errored message">single error frame+</error><system-out>errored stdout</system-out><system-err>errored stderr</system-err></testcase></testsuite></testsuites>