diff --git a/hspec-junit-formatter.cabal b/hspec-junit-formatter.cabal --- a/hspec-junit-formatter.cabal +++ b/hspec-junit-formatter.cabal @@ -1,25 +1,19 @@ -cabal-version: 1.18 -name: hspec-junit-formatter -version: 1.2.1.0 -license: MIT -license-file: LICENSE -copyright: 2021 Renaissance Learning Inc -maintainer: engineering@freckle.com -author: Freckle R&D -homepage: https://github.com/freckle/hspec-junit-formatter#readme -bug-reports: https://github.com/freckle/hspec-junit-formatter/issues -synopsis: A JUnit XML runner/formatter for hspec +cabal-version: 1.18 +name: hspec-junit-formatter +version: 1.3.0.0 +license: MIT +license-file: LICENSE +copyright: 2021 Renaissance Learning Inc +maintainer: engineering@freckle.com +author: Freckle R&D +homepage: https://github.com/freckle/hspec-junit-formatter#readme +bug-reports: https://github.com/freckle/hspec-junit-formatter/issues +synopsis: A JUnit XML runner/formatter for hspec description: Allows hspec tests to write JUnit XML output for parsing in various tools. -category: Testing -build-type: Simple -extra-source-files: - tests/golden/default-base-4.21.xml - tests/golden/default.xml - tests/golden/prefixed-base-4.21.xml - tests/golden/prefixed.xml - +category: Testing +build-type: Simple extra-doc-files: README.md CHANGELOG.md @@ -58,15 +52,15 @@ array >=0.5.4.0, base >=4.16.4.0 && <5, conduit >=1.3.5, - containers >=0.6.5.1, directory >=1.3.6.2, - exceptions >=0.10.4, filepath >=1.4.2.2, hspec-api >=2.10.0, hspec-core >=2.10.0, iso8601-time >=0.1.5, + mtl >=2.2.2, regex-base >=0.94.0.2, regex-tdfa >=1.3.2.1, + semigroups >=0.20, text >=1.2.5.0, time >=1.11.1.1, xml-conduit >=1.10.0.0, @@ -137,12 +131,10 @@ build-depends: base >=4.16.4.0 && <5, - containers >=0.6.5.1, filepath >=1.4.2.2, hspec >=2.10.0, - hspec-golden >=0.2.1.0, hspec-junit-formatter, - pretty-simple >=4.1.2.0, + iso8601-time >=0.1.5, temporary >=1.3, text >=1.2.5.0, xml-conduit >=1.10.0.0 diff --git a/library/Test/Hspec/JUnit/Format.hs b/library/Test/Hspec/JUnit/Format.hs --- a/library/Test/Hspec/JUnit/Format.hs +++ b/library/Test/Hspec/JUnit/Format.hs @@ -1,23 +1,40 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + module Test.Hspec.JUnit.Format ( junit ) where import Prelude -import Conduit (runConduitRes, sinkFile, yield, (.|)) +import Conduit import Control.Applicative ((<|>)) -import Data.Functor ((<&>)) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack, unpack) -import Data.Text qualified as T -import Data.Time (getCurrentTime) +import Control.Exception (displayException) +import Control.Monad.Reader (runReaderT) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Monoid (First (..)) +import Data.Semigroup (Sum (..)) +import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) +import Data.Text (Text, pack) +import Data.Time (UTCTime, getCurrentTime) +import Data.Typeable (typeOf) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) import System.Directory (createDirectoryIfMissing) -import System.FilePath (splitFileName) +import System.FilePath (takeDirectory) import Test.Hspec.Api.Format.V1 + ( Event (..) + , Format + , FormatConfig + , Item (..) + , Location (..) + , Path + ) +import Test.Hspec.Api.Format.V1 qualified as Hspec import Test.Hspec.JUnit.Config as Config -import Test.Hspec.JUnit.Render (renderJUnit) -import Test.Hspec.JUnit.Schema qualified as Schema +import Test.Hspec.JUnit.Render +import Test.Hspec.JUnit.Schema import Text.XML.Stream.Render (def, renderBytes) import Text.XML.Stream.Render.Internal (rsPretty) @@ -29,121 +46,169 @@ Progress _ _ -> pure () ItemStarted _ -> pure () ItemDone _ _ -> pure () - Done paths -> do - time <- getCurrentTime - - let (directory, _) = splitFileName file - createDirectoryIfMissing True directory - - let - groups = groupItems paths - output = - Schema.Suites - { name = suiteName - , suites = - groups <&> \(group, items) -> do - let suite xs = - Schema.Suite - { name = group - , timestamp = time - , cases = xs - } - suite $ uncurry (itemToTestCase applyPrefix group) <$> items - } - + Done items -> do + now <- getCurrentTime + createDirectoryIfMissing True $ takeDirectory file runConduitRes - $ yield output - .| renderJUnit dropConsoleFormatting + $ transPipe (`runReaderT` junitConfig) + $ renderTestsuites (formatTestsuites now suiteName items) .| renderBytes renderConfig .| sinkFile file where file = getJUnitConfigOutputFile junitConfig suiteName = getJUnitConfigSuiteName junitConfig - applyPrefix = getJUnitPrefixSourcePath junitConfig - dropConsoleFormatting = getJUnitConfigDropConsoleFormatting junitConfig renderConfig = def {rsPretty = getJUnitConfigPretty junitConfig} -groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])] -groupItems = Map.toList . Map.fromListWith (<>) . fmap group +formatTestsuites :: UTCTime -> Text -> [(Path, Item)] -> Testsuites +formatTestsuites now suiteName items = + Testsuites + { name = Attr suiteName + , tests = getSum totals.tests + , failures = getSum totals.failures + , errors = getSum totals.errors + , skipped = getSum totals.skipped + , assertions = getSum totals.assertions + , time = getSum totals.time + , timestamp = Attr now + , children = suites + } where - group ((path, name), item) = - (T.intercalate "/" $ pack <$> path, [(pack name, item)]) + -- Group all items by prefix and then convert each group to a suite. In an + -- ideal world, we would build a tree instead so we could correctly render + -- nested contexts as nested testsuites, but that is hard and I'm tired. + suites :: [Testsuite] + suites = map (formatTestsuite now) $ NE.groupAllWith (fst . fst) items -itemToTestCase - :: (FilePath -> FilePath) -> Text -> Text -> Item -> Schema.TestCase -itemToTestCase applyPrefix group name item = - Schema.TestCase - { location = - toSchemaLocation applyPrefix - <$> (itemResultLocation item <|> itemLocation item) - , className = group - , name = name - , duration = unSeconds $ itemDuration item - , result = case itemResult item of - Success -> Nothing - Pending mLocation mMessage -> - Just - $ Schema.Skipped - $ prefixLocation mLocation - $ prefixInfo - $ maybe "" pack mMessage - Failure mLocation reason -> - Just - $ Schema.Failure "error" - $ prefixLocation mLocation - $ prefixInfo - $ reasonToText reason + totals :: SuiteTotals + totals = foldMap getSuiteTotals suites + +formatTestsuite :: UTCTime -> NonEmpty (Path, Item) -> Testsuite +formatTestsuite now items = + Testsuite + { name = Attr $ pack $ intercalate "/" path + , tests = getSum totals.tests + , failures = getSum totals.failures + , errors = getSum totals.errors + , skipped = getSum totals.skipped + , assertions = getSum totals.assertions + , time = getSum totals.time + , timestamp = Attr now + , file = getFirst totals.file + , children } where - prefixLocation mLocation str = case mLocation of - Nothing -> str - Just l -> - mconcat - [ pack $ applyPrefix $ locationFile l - , ":" - , pack $ show $ locationLine l - , ":" - , pack $ show $ locationColumn l - , "\n" - ] - <> str - prefixInfo str - | T.null $ T.strip $ pack $ itemInfo item = str - | otherwise = pack (itemInfo item) <> "\n\n" <> str + path :: [String] + path = fst $ fst $ NE.head items -itemResultLocation :: Item -> Maybe Location -itemResultLocation item = case itemResult item of - Success -> Nothing - Pending mLocation _ -> mLocation - Failure mLocation _ -> mLocation + children :: [TestsuiteChild] + children = NE.toList $ TestsuiteTestcase . formatTestcase <$> items -toSchemaLocation :: (FilePath -> FilePath) -> Location -> Schema.Location -toSchemaLocation applyPrefix l = - Schema.Location - { Schema.file = applyPrefix $ locationFile l - , Schema.line = fromIntegral $ max 0 $ locationLine l + totals :: SuiteTotals + totals = foldMap getSuiteChildTotals children + +formatTestcase :: (Path, Item) -> Testcase +formatTestcase ((path, name), item) = + Testcase + { name = Attr $ pack name + , classname = Attr $ pack $ intercalate "/" path + , assertions = Attr 0 -- not available with Hspec + , time = Attr $ itemDuration item + , file = Attr . locationFile <$> location + , line = Attr . fromIntegral . locationLine <$> location + , properties = Nothing + , systemStream = [] + , child } + where + (location, child) = case itemResult item of + Hspec.Success -> + ( itemLocation item + , TestcaseEmpty + ) + Hspec.Pending mLocation mMessage -> + ( mLocation <|> itemLocation item + , TestcaseSkipped $ Skipped $ maybe "" (Attr . pack) mMessage + ) + Hspec.Failure mLocation reason -> + ( mLocation <|> itemLocation item + , formatFailureReason reason + ) -unSeconds :: Seconds -> Double -unSeconds (Seconds x) = x +formatFailureReason :: Hspec.FailureReason -> TestcaseChild +formatFailureReason = \case + Hspec.NoReason -> + TestcaseFailure + $ Failure + { message = "No reason given" + , type_ = "Failure.NoReason" + , content = "No reason given" + } + Hspec.Reason msg -> + TestcaseFailure + $ Failure + { message = Attr $ firstLineOf msg + , type_ = "Failure.Reason" + , content = Content $ pack $ msg <> "\n" + } + Hspec.ExpectedButGot mPrefix expected got -> + TestcaseFailure + $ Failure + { message = Attr "Received value did not match expected" + , type_ = Attr "Failure.ExpectedButGot" + , content = + Content + $ pack + $ mconcat + [ maybe "" (<> "\n") mPrefix + , "Expected: " <> show expected <> "\n" + , " but got: " <> show got <> "\n" + ] + } + Hspec.Error mPrefix ex -> + TestcaseError + $ Error + { message = Attr $ firstLineOf $ displayException ex + , type_ = Attr $ pack $ show $ typeOf ex + , content = + Content + $ pack + $ mconcat + [ maybe "" (<> "\n") mPrefix + , displayException ex <> "\n" + ] + } + where + firstLineOf = + maybe "" (pack . NE.head) + . NE.nonEmpty + . lines -reasonToText :: FailureReason -> Text -reasonToText = \case - Error _ err -> pack $ show err - NoReason -> "no reason" - Reason err -> pack err - ExpectedButGot preface expected actual -> - T.unlines - $ pack - <$> fromMaybe "" preface - : ( foundLines "expected" expected - <> foundLines " but got" actual - ) +data SuiteTotals = SuiteTotals + { tests :: Sum (Attr Natural) + , failures :: Sum (Attr Natural) + , errors :: Sum (Attr Natural) + , skipped :: Sum (Attr Natural) + , assertions :: Sum (Attr Natural) + , time :: Sum (Attr Seconds) + , file :: First (Attr FilePath) + } + deriving stock (Generic) + deriving (Monoid, Semigroup) via GenericSemigroupMonoid SuiteTotals -foundLines :: Show a => Text -> a -> [String] -foundLines msg found = case lines' of - [] -> [] - first : rest -> - unpack (msg <> ": " <> first) : (unpack . (T.replicate 9 " " <>) <$> rest) - where - lines' = T.lines . pack $ show found +getSuiteTotals :: Testsuite -> SuiteTotals +getSuiteTotals s = foldMap getSuiteChildTotals s.children + +getSuiteChildTotals :: TestsuiteChild -> SuiteTotals +getSuiteChildTotals = \case + TestsuiteTestcase tc -> + let + base :: SuiteTotals + base = mempty {tests = 1, time = Sum tc.time, file = First tc.file} + in + case tc.child of + TestcaseEmpty -> base + TestcaseSkipped {} -> base {skipped = 1} + TestcaseFailure {} -> base {failures = 1} + TestcaseError {} -> base {errors = 1} + TestsuiteTestsuite s -> getSuiteTotals s + _ -> mempty diff --git a/library/Test/Hspec/JUnit/Render.hs b/library/Test/Hspec/JUnit/Render.hs --- a/library/Test/Hspec/JUnit/Render.hs +++ b/library/Test/Hspec/JUnit/Render.hs @@ -1,103 +1,215 @@ module Test.Hspec.JUnit.Render - ( renderJUnit + ( renderTestsuites ) where import Prelude -import Conduit (ConduitT, awaitForever, mergeSource, yield, yieldMany, (.|)) -import Control.Monad.Catch (MonadThrow) +import Conduit (ConduitT) +import Control.Monad (unless) +import Control.Monad.Reader (MonadReader (..), asks) import Data.Array qualified as Array -import Data.Conduit.List qualified as CL +import Data.Fixed (Nano) import Data.Foldable (traverse_) +import Data.Semigroup (Endo (..)) import Data.Text (Text, pack) -import Data.Text qualified as Text +import Data.Text qualified as T import Data.Time.ISO8601 (formatISO8601) import Data.XML.Types (Event) +import Test.Hspec.JUnit.Config import Test.Hspec.JUnit.Schema - ( Location (..) - , Result (..) - , Suite (..) - , Suites (..) - , TestCase (..) - ) -import Text.Printf import Text.Regex.Base qualified as Regex -import Text.Regex.TDFA.Text qualified as Regex -import Text.XML.Stream.Render (attr, content, tag) +import Text.Regex.TDFA.Text (Regex) +import Text.XML.Stream.Render (attr, content, optionalAttr, tag) -renderJUnit :: MonadThrow m => Bool -> ConduitT Suites Event m () -renderJUnit shouldDropConsoleFormatting = awaitForever $ \s -> - tag "testsuites" (attr "name" s.name) - $ yieldMany s.suites - .| mergeSource idStream - .| suite shouldDropConsoleFormatting - where - idStream = CL.iterate (+ 1) 0 +renderTestsuites + :: MonadReader JUnitConfig m + => Testsuites + -> ConduitT i Event m () +renderTestsuites s = do + tag + "testsuites" + ( attr "name" (unAttr id s.name) + <> attr "tests" (unAttr (pack . show) s.tests) + <> attr "failures" (unAttr (pack . show) s.failures) + <> attr "errors" (unAttr (pack . show) s.errors) + <> attr "skipped" (unAttr (pack . show) s.skipped) + <> attr "assertions" (unAttr (pack . show) s.assertions) + <> attr "time" (unAttr unSeconds s.time) + <> attr "timestamp" (unAttr (pack . formatISO8601) s.timestamp) + ) + $ traverse_ renderTestsuite s.children -suite :: MonadThrow m => Bool -> ConduitT (Int, Suite) Event m () -suite shouldDropConsoleFormatting = awaitForever $ \(i, s) -> - tag "testsuite" (attributes i s) $ do - tag "properties" mempty mempty - yieldMany s.cases .| testCase shouldDropConsoleFormatting - where - -- TODO these need to be made real values - attributes i s = - attr "name" s.name - <> attr "package" s.name - <> attr "id" (tshow i) - <> attr "time" (roundToStr $ sumDurations s.cases) - <> attr "timestamp" (pack $ formatISO8601 s.timestamp) - <> attr "hostname" "localhost" - <> attr "tests" (tshow $ length s.cases) - <> attr "failures" (tshow $ length [() | Just Failure {} <- (.result) <$> s.cases]) - <> attr "errors" "0" - <> attr "skipped" (tshow $ length [() | Just Skipped {} <- (.result) <$> s.cases]) +renderTestsuite + :: MonadReader JUnitConfig m + => Testsuite + -> ConduitT i Event m () +renderTestsuite s = do + prefix <- asks getJUnitPrefixSourcePath -tshow :: Show a => a -> Text -tshow = pack . show + tag + "testsuite" + ( attr "name" (unAttr id s.name) + <> attr "tests" (unAttr (pack . show) s.tests) + <> attr "failures" (unAttr (pack . show) s.failures) + <> attr "errors" (unAttr (pack . show) s.errors) + <> attr "skipped" (unAttr (pack . show) s.skipped) + <> attr "assertions" (unAttr (pack . show) s.assertions) + <> attr "time" (unAttr unSeconds s.time) + <> attr "timestamp" (unAttr (pack . formatISO8601) s.timestamp) + <> optionalAttr "file" (unAttr (pack . prefix) <$> s.file) + ) + $ traverse_ renderTestsuiteChild s.children -testCase :: MonadThrow m => Bool -> ConduitT TestCase Event m () -testCase shouldDropConsoleFormatting = - awaitForever $ \(TestCase mLocation className name duration mResult) -> - tag "testcase" (attributes mLocation className name duration) - $ traverse_ yield mResult - .| result shouldDropConsoleFormatting - where - attributes mLocation className name duration = - maybe mempty (attr "file" . pack . (.file)) mLocation - <> maybe mempty (attr "line" . pack . show . (.line)) mLocation - <> attr "name" name - <> attr "classname" className - <> attr "time" (roundToStr duration) +renderTestsuiteChild + :: MonadReader JUnitConfig m + => TestsuiteChild + -> ConduitT i Event m () +renderTestsuiteChild = \case + TestsuiteProperties x -> renderProperties x + TestsuiteSystemOut x -> renderSystemOut x + TestsuiteSystemErr x -> renderSystemErr x + TestsuiteTestcase x -> renderTestcase x + TestsuiteTestsuite x -> renderTestsuite x -result :: MonadThrow m => Bool -> ConduitT Result Event m () -result shouldDropConsoleFormatting = awaitForever go - where - go (Failure fType contents) = - tag "failure" (attr "type" fType) $ content $ dropConsoleFormatting contents - go (Skipped contents) = tag "skipped" mempty $ content $ dropConsoleFormatting contents +renderProperties + :: MonadReader JUnitConfig m + => Properties + -> ConduitT i Event m () +renderProperties ps = unless (null ps.unwrap) $ do + tag "properties" mempty $ traverse_ renderProperty $ ps.unwrap - -- Drops ANSI control characters which might be used to set colors. - -- Including these breaks XML, there is not much point encoding them. - dropConsoleFormatting :: Text -> Text - dropConsoleFormatting input - | shouldDropConsoleFormatting = - let - regex = Regex.makeRegex (pack "\x1b\\[[0-9;]*[mGKHF]") :: Regex.Regex - matches = Regex.matchAll regex input - dropMatch (offset, len) input' = - let - (begining, rest) = Text.splitAt offset input' - (_, end) = Text.splitAt len rest - in - begining <> end - matchTuples = map (Array.! 0) matches - in - foldr dropMatch input matchTuples - | otherwise = input +renderProperty + :: MonadReader JUnitConfig m + => Property + -> ConduitT i Event m () +renderProperty p = case p.value of + Left a -> + tag "property" (attr "name" (unAttr id p.name) <> attr "value" (unAttr id a)) + $ pure () + Right c -> tag "property" (attr "name" (unAttr id p.name)) $ renderContent c -sumDurations :: [TestCase] -> Double -sumDurations cases = sum $ (.duration) <$> cases +renderSystemOut + :: MonadReader JUnitConfig m + => SystemOut + -> ConduitT i Event m () +renderSystemOut = tag "system-out" mempty . renderContent . (.unwrap) -roundToStr :: PrintfArg a => a -> Text -roundToStr = pack . printf "%0.9f" +renderSystemErr + :: MonadReader JUnitConfig m + => SystemErr + -> ConduitT i Event m () +renderSystemErr = tag "system-err" mempty . renderContent . (.unwrap) + +renderTestcase + :: MonadReader JUnitConfig m + => Testcase + -> ConduitT i Event m () +renderTestcase c = do + prefix <- asks getJUnitPrefixSourcePath + + tag + "testcase" + ( attr "name" (unAttr id c.name) + <> attr "classname" (unAttr id c.classname) + <> attr "assertions" (unAttr (pack . show) c.assertions) + <> attr "time" (unAttr unSeconds c.time) + <> optionalAttr "file" (unAttr (pack . prefix) <$> c.file) + <> optionalAttr "line" (unAttr (pack . show) <$> c.line) + ) + $ do + traverse_ renderProperties c.properties + traverse_ (either renderSystemOut renderSystemErr) c.systemStream + renderTestcaseChild c.child + +renderTestcaseChild + :: MonadReader JUnitConfig m + => TestcaseChild + -> ConduitT i Event m () +renderTestcaseChild = \case + TestcaseEmpty -> pure () + TestcaseSkipped x -> renderSkipped x + TestcaseFailure x -> renderFailure x + TestcaseError x -> renderError x + +renderSkipped + :: MonadReader JUnitConfig m + => Skipped + -> ConduitT i Event m () +renderSkipped s = tag "skipped" (attr "message" (unAttr id s.message)) $ pure () + +renderFailure + :: MonadReader JUnitConfig m + => Failure + -> ConduitT i Event m () +renderFailure f = + tag + "failure" + (attr "message" (unAttr id f.message) <> attr "type" (unAttr id f.type_)) + $ renderContent f.content + +renderError + :: MonadReader JUnitConfig m + => Error + -> ConduitT i Event m () +renderError e = + tag + "error" + (attr "message" (unAttr id e.message) <> attr "type" (unAttr id e.type_)) + $ renderContent e.content + +renderContent + :: MonadReader JUnitConfig m + => Content + -> ConduitT i Event m () +renderContent c = do + shouldDropConsoleFormatting <- asks getJUnitConfigDropConsoleFormatting + + let clean = + if shouldDropConsoleFormatting + then dropConsoleFormatting + else id + + content $ clean $ c.unwrap + +unSeconds :: Seconds -> Text +unSeconds (Seconds d) = pack $ show $ realToFrac @_ @Nano d + +-- | Safely render an attribute +-- +-- HTML encoding is handled by @xml-conduit@, but additionally we: +-- +-- * Drop console formatting (always) +-- * Extra-escape unsupported characters (e.g @\a@ becomes @\\a@) +unAttr :: (a -> Text) -> Attr a -> Text +unAttr f = escapeIllegal . dropConsoleFormatting . f . (.unwrap) + +escapeIllegal :: Text -> Text +escapeIllegal = + appEndo + $ foldMap + (\(a, b) -> Endo $ T.replace a b) + [ ("\0", "\\0") + , ("\a", "\\a") + , ("\b", "\\b") + , ("\f", "\\f") + , ("\v", "\\v") + , ("\ESC", "\\ESC") + ] + +-- | Drop ANSI control characters which might be used to set colors +-- +-- We always do this in attribute values, since they'd only break XML, but we +-- only do it in content if configured by options, since we want any content +-- node changes to be opt-in. +dropConsoleFormatting :: Text -> Text +dropConsoleFormatting input = + foldr (dropBetween . (Array.! 0)) input $ Regex.matchAll escRegex input + +escRegex :: Regex +escRegex = Regex.makeRegex ("\x1b\\[[0-9;]*[mGKHF]" :: Text) + +dropBetween :: (Int, Int) -> Text -> Text +dropBetween (offset, len) input = begining <> end + where + (begining, rest) = T.splitAt offset input + (_, end) = T.splitAt len rest diff --git a/library/Test/Hspec/JUnit/Schema.hs b/library/Test/Hspec/JUnit/Schema.hs --- a/library/Test/Hspec/JUnit/Schema.hs +++ b/library/Test/Hspec/JUnit/Schema.hs @@ -1,44 +1,201 @@ +-- | The structure of a JUnit XML file +-- +-- This intends to be a complete and accurate representation of +-- , though we +-- don't (and sometimes can't) exercise all of it. module Test.Hspec.JUnit.Schema - ( Suites (..) - , Suite (..) - , TestCase (..) - , Location (..) - , Result (..) + ( Testsuites (..) + , Testsuite (..) + , TestsuiteChild (..) + , Testcase (..) + , TestcaseChild (..) + , Skipped (..) + , Failure (..) + , Error (..) + , Properties (..) + , Property (..) + , SystemOut (..) + , SystemErr (..) + + -- * Tagged XML types + , Attr (..) + , Content (..) + + -- * Other wrapper types + , Seconds (..) ) where import Prelude +import Data.String (IsString) import Data.Text (Text) import Data.Time (UTCTime) -import Numeric.Natural +import Numeric.Natural (Natural) +import Test.Hspec.Core.Format (Seconds (..)) -data Suites = Suites - { name :: Text - , suites :: [Suite] +-- | @@ +-- +-- Usually the root element of a JUnit XML file. Some tools leave out the +-- @@ element if there is only a single top-level @@ +-- element (which is then used as the root element). +data Testsuites = Testsuites + { name :: Attr Text + -- ^ Name of the entire test run + , tests :: Attr Natural + -- ^ Total number of tests in this file + , failures :: Attr Natural + -- ^ Total number of failed tests in this file + , errors :: Attr Natural + -- ^ Total number of errored tests in this file + , skipped :: Attr Natural + -- ^ Total number of skipped tests in this file + , assertions :: Attr Natural + -- ^ Total number of assertions for all tests in this file + , time :: Attr Seconds + -- ^ Aggregated time of all tests in this file in seconds + , timestamp :: Attr UTCTime + -- ^ Date and time of when the test run was executed (in ISO 8601 format) + , children :: [Testsuite] + -- ^ Only @@s can be descendents of this node } - deriving stock (Show) -data Suite = Suite - { name :: Text - , timestamp :: UTCTime - , cases :: [TestCase] +-- | @@ +-- +-- A test suite usually represents a class, folder or group of tests. There can +-- be many test suites in an XML file, and there can be test suites under other +-- test suites. +data Testsuite = Testsuite + { name :: Attr Text + -- ^ Name of the test suite (e.g. class name or folder name) + , tests :: Attr Natural + -- ^ Total number of tests in this suite + , failures :: Attr Natural + -- ^ Total number of failed tests in this suite + , errors :: Attr Natural + -- ^ Total number of errored tests in this suite + , skipped :: Attr Natural + -- ^ Total number of skipped tests in this suite + , assertions :: Attr Natural + -- ^ Total number of assertions for all tests in this suite + , time :: Attr Seconds + -- ^ Aggregated time of all tests in this file in seconds + , timestamp :: Attr UTCTime + -- ^ Date and time of when the test suite was executed (in ISO 8601 format) + , file :: Maybe (Attr FilePath) + -- ^ Source code file of this test suite + , children :: [TestsuiteChild] } - deriving stock (Show) -data TestCase = TestCase - { location :: Maybe Location - , className :: Text - , name :: Text - , duration :: Double - , result :: Maybe Result +-- | @@ can contain nodes that are any of these +data TestsuiteChild + = TestsuiteProperties Properties + | TestsuiteSystemOut SystemOut + | TestsuiteSystemErr SystemErr + | TestsuiteTestcase Testcase + | TestsuiteTestsuite Testsuite + +-- | @@ +-- +-- Test suites can have additional properties such as environment variables or +-- version numbers. Some tools also support properties for test cases. +newtype Properties = Properties + { unwrap :: [Property] } - deriving stock (Show) -data Location = Location - { file :: FilePath - , line :: Natural +-- | @@ +-- +-- Each property has a name and value. Some tools also support properties with +-- text values instead of value attributes. +data Property = Property + { name :: Attr Text + , value :: Either (Attr Text) Content } - deriving stock (Show) -data Result = Failure Text Text | Skipped Text - deriving stock (Show) +-- | @@ +-- +-- Optionally data written to standard out for the suite. Also supported on a +-- test case level, see below. +newtype SystemOut = SystemOut + { unwrap :: Content + } + +-- | @@ +-- +-- Optionally data written to standard error for the suite. Also supported on a +-- test case level, see below. +newtype SystemErr = SystemErr + { unwrap :: Content + } + +-- | @@ +-- +-- There are one or more test cases in a test suite. A test passed if there +-- isn't an additional result element (skipped, failure, error). +data Testcase = Testcase + { name :: Attr Text + -- ^ The name of this test case, often the method name + , classname :: Attr Text + -- ^ The name of the parent class/folder, often the same as the suite's name + , assertions :: Attr Natural + -- ^ Number of assertions checked during test case execution + , time :: Attr Seconds + -- ^ Execution time of the test in seconds + , file :: Maybe (Attr FilePath) + -- ^ Source code file of this test case + , line :: Maybe (Attr Natural) + -- ^ Source code line number of the start of this test case + , properties :: Maybe Properties + , systemStream :: [Either SystemOut SystemErr] + -- ^ Stored as a combined list to represent ordering and interleaving + , child :: TestcaseChild + } + +-- | @@ will contain only one of these +data TestcaseChild + = -- | Success case + TestcaseEmpty + | TestcaseSkipped Skipped + | TestcaseFailure Failure + | TestcaseError Error + +-- | @@ +-- +-- Indicates that the test was not executed. Can have an optional message +-- describing why the test was skipped. +newtype Skipped = Skipped + { message :: Attr Text + } + +-- | @@ +-- +-- The test failed because one of the assertions/checks failed. Can have a +-- message and failure type, often the assertion type or class. The text content +-- of the element often includes the failure description or stack trace. +data Failure = Failure + { message :: Attr Text + , type_ :: Attr Text + , content :: Content + -- ^ Failure description or stack trace + } + +-- | @@ +-- +-- The test had an unexpected error during execution. Can have a message and +-- error type, often the exception type or class. The text content of the +-- element often includes the error description or stack trace. +data Error = Error + { message :: Attr Text + , type_ :: Attr Text + , content :: Content + -- ^ Error description or stack trace + } + +newtype Attr a = Attr + { unwrap :: a + } + deriving newtype (IsString, Num) + +newtype Content = Content + { unwrap :: Text + } + deriving newtype (IsString) diff --git a/tests/Test/Hspec/JUnit/FormatterSpec.hs b/tests/Test/Hspec/JUnit/FormatterSpec.hs --- a/tests/Test/Hspec/JUnit/FormatterSpec.hs +++ b/tests/Test/Hspec/JUnit/FormatterSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Test.Hspec.JUnit.FormatterSpec ( spec @@ -7,95 +7,331 @@ import Prelude import Control.Monad (void) -import Data.Map.Strict qualified as Map -import Data.Text.Lazy qualified as LT +import Data.Fixed (Micro, Nano) +import Data.Maybe (isJust) +import Data.Text (Text, unpack) +import Data.Text qualified as T +import Data.Time.ISO8601 (parseISO8601) import Example qualified -import System.FilePath ((<.>), ()) +import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -import Test.Hspec.Golden import Test.Hspec.JUnit.Config import Test.Hspec.JUnit.Formatter qualified as Formatter -import Test.Hspec.Runner -import Text.Pretty.Simple (pShowNoColor) +import Test.Hspec.Runner qualified as Hspec +import Text.Read (readMaybe) import Text.XML qualified as XML -import Text.XML.Stream.Render.Internal qualified as XML +import Text.XML.Cursor spec :: Spec spec = do - it "matches golden file" $ do - junitGolden "default" id + context "ExampleSpec" $ do + doc <- runIO $ fromDocument <$> renderJUnitXml testConfig Example.spec - it "matches golden file with prefixing" $ do - junitGolden "prefixed" $ setJUnitConfigSourcePathPrefix "lol/monorepo" + context "time attributes" $ do + it "sums correctly on testsuites and testsuite" $ do + let + -- Do the summation at Nano... + readNano :: Text -> Nano + readNano = maybe 0 realToFrac . readMaybe @Double . unpack --- | Run @Example.spec@ and compare XML to a golden file -junitGolden - :: String - -- ^ Unique name - -> (JUnitConfig -> JUnitConfig) - -- ^ Any modification to make to the 'JUnitConfig' before running - -> IO (Golden XML.Document) -junitGolden name modifyConfig = do - actual <- withSystemTempDirectory "" $ \tmp -> do - let junitConfig = - modifyConfig - $ setJUnitConfigPretty True - $ setJUnitConfigOutputDirectory tmp - $ setJUnitConfigOutputName "test.xml" - $ defaultJUnitConfig "hspec-junit-format" + -- ...but truncate to Micro for comparison + readTimes :: [[Text]] -> Micro + readTimes = realToFrac . sum . concatMap (map readNano) - runSpec' $ Formatter.use junitConfig Example.spec - readNormalizedXML $ tmp "test.xml" + suitesTime :: Micro + suitesTime = + readTimes + $ doc + $| element "testsuites" + &| attribute "time" - pure - Golden - { output = actual - , encodePretty = LT.unpack . pShowNoColor - , writeToFile = XML.writeFile (XML.def {XML.rsPretty = True}) - , readFromFile = readNormalizedXML - , goldenFile = "tests" "golden" name <> suffix <.> "xml" - , actualFile = Nothing - , failFirstTime = False - } + suiteTimes :: Micro + suiteTimes = + readTimes + $ doc + $| element "testsuites" + &/ element "testsuite" + &| attribute "time" -runSpec' :: Spec -> IO () -runSpec' x = do - (config, forest) <- evalSpec defaultConfig x - void $ runSpecForest forest config + casesTimes :: Micro + casesTimes = + readTimes + $ doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &| attribute "time" -readNormalizedXML :: FilePath -> IO XML.Document -readNormalizedXML = fmap normalizeDoc . XML.readFile XML.def + suitesTime `shouldSatisfy` (> 0) + suitesTime `shouldBe` suiteTimes + suitesTime `shouldBe` casesTimes -normalizeDoc :: XML.Document -> XML.Document -normalizeDoc = removeTimeAttributes + context "timestamp attributes" $ do + it "has the same timestamp on testsuites and testsuite" $ do + let + [suitesTimestamp] = + concatMap (map (parseISO8601 . unpack)) + $ doc + $| element "testsuites" + &| attribute "timestamp" --- | Remove volatile attributes so they don't invalidate comparison -removeTimeAttributes :: XML.Document -> XML.Document -removeTimeAttributes = - removeAttributesByName "time" . removeAttributesByName "timestamp" + [suite1Timestamp, suite2Timestamp] = + concatMap (map (parseISO8601 . unpack)) + $ doc + $| element "testsuites" + &/ element "testsuite" + &| attribute "timestamp" -removeAttributesByName :: XML.Name -> XML.Document -> XML.Document -removeAttributesByName name doc = - doc - { XML.documentRoot = go $ XML.documentRoot doc - } - where - go el = - el - { XML.elementAttributes = Map.delete name $ XML.elementAttributes el - , XML.elementNodes = map (onNodeElement go) $ XML.elementNodes el - } + suitesTimestamp `shouldSatisfy` isJust + suite1Timestamp `shouldSatisfy` isJust + suite2Timestamp `shouldSatisfy` isJust + suite1Timestamp `shouldBe` suitesTimestamp + suite2Timestamp `shouldBe` suitesTimestamp - onNodeElement f = \case - XML.NodeElement el -> XML.NodeElement $ f el - n -> n + context "testsuites node" $ do + it "produces one, with our package name" $ do + ( doc + $| element "testsuites" + &| attribute "name" + ) + `shouldBe` [["hspec-junit-format"]] --- Store a separate golden for newer base because throwIO's behavior changed --- such that different location data is present and so our output changes -suffix :: String -#if MIN_VERSION_base(4,21,0) -suffix = "-base-4.21" -#else -suffix = "" -#endif + context "testsuite nodes" $ do + it "produces two" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + ) + `shouldSatisfy` (== 2) . length + + it "has name" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &| attribute "name" + ) + `shouldBe` [ ["Some section"] + , ["Some section/A grouped context"] + ] + + context "testcase nodes" $ do + it "has time" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &| attribute "time" + ) + `shouldSatisfy` (== 6) . length + + it "has timestamp" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &| attribute "timestamp" + ) + `shouldSatisfy` (== 6) . length + + it "has classname" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &| attribute "classname" + ) + `shouldBe` ( replicate 2 ["Some section"] + <> replicate 4 ["Some section/A grouped context"] + ) + + it "has file" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &| attribute "file" + ) + `shouldBe` replicate 6 ["tests/Example.hs"] + + it "has name" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &| attribute "name" + ) + `shouldBe` [ ["has an expectation"] + , ["has a failure"] + , ["happens in a group"] + , ["also happens in a group"] + , ["gets skipped"] + , ["throws a colourful exception"] + ] + + context "first testsuite" $ do + let [testsuite, _] = doc $| element "testsuites" &/ element "testsuite" + + it "has correct counts" $ do + (testsuite $| attribute "errors") `shouldBe` ["0"] + (testsuite $| attribute "failures") `shouldBe` ["1"] + (testsuite $| attribute "skipped") `shouldBe` ["0"] + (testsuite $| attribute "tests") `shouldBe` ["2"] + + it "produces two testcase nodes" $ do + (testsuite $/ element "testcase") `shouldSatisfy` (== 2) . length + + context "first testcase" $ do + let [testcase, _] = testsuite $/ element "testcase" + + it "has line" $ do + (testcase $| attribute "line") `shouldBe` ["16"] + + it "has name" $ do + (testcase $| attribute "name") `shouldBe` ["has an expectation"] + + it "has no child nodes" $ do + (testcase $| child &| node) `shouldBe` [] + + context "second testcase" $ do + let [_, testcase] = testsuite $/ element "testcase" + + it "has line" $ do + (testcase $| attribute "line") `shouldBe` ["19"] + + it "has name" $ do + (testcase $| attribute "name") `shouldBe` ["has a failure"] + + it "has a failure reported" $ do + ( testcase + $/ element "failure" + &/ content + ) + `shouldBe` [ T.unlines + [ "Expected: \"False\"" + , " but got: \"True\"" + ] + ] + + context "second testsuite" $ do + let [_, testsuite] = + doc + $| element "testsuites" + &/ element "testsuite" + + it "has correct counts" $ do + (testsuite $| attribute "errors") `shouldBe` ["1"] + (testsuite $| attribute "failures") `shouldBe` ["0"] + (testsuite $| attribute "skipped") `shouldBe` ["1"] + (testsuite $| attribute "tests") `shouldBe` ["4"] + + it "produces four testcase nodes" $ do + (testsuite $/ element "testcase") `shouldSatisfy` (== 4) . length + + context "first testcase" $ do + let [testcase, _, _, _] = testsuite $/ element "testcase" + + it "has line" $ do + (testcase $| attribute "line") `shouldBe` ["22"] + + it "has name" $ do + (testcase $| attribute "name") `shouldBe` ["happens in a group"] + + it "has no child nodes" $ do + (testcase $| child &| node) `shouldBe` [] + + context "second testcase" $ do + let [_, testcase, _, _] = testsuite $/ element "testcase" + + it "has line" $ do + (testcase $| attribute "line") `shouldBe` ["24"] + + it "has name" $ do + (testcase $| attribute "name") `shouldBe` ["also happens in a group"] + + it "has no child nodes" $ do + (testcase $| child &| node) `shouldBe` [] + + context "third testcase" $ do + let [_, _, testcase, _] = testsuite $/ element "testcase" + + it "has line" $ do + (testcase $| attribute "line") `shouldBe` ["27"] + + it "has name" $ do + (testcase $| attribute "name") `shouldBe` ["gets skipped"] + + it "has a skipped node" $ do + ( testcase + $/ element "skipped" + &| attribute "message" + ) + `shouldBe` [["some reason"]] + + context "fourth testcase" $ do + let [_, _, _, testcase] = testsuite $/ element "testcase" + + it "has line" $ do + pendingWith "Newer base returns line 29" + (testcase $| attribute "line") `shouldBe` ["28"] + + it "has name" $ do + (testcase $| attribute "name") `shouldBe` ["throws a colourful exception"] + + context "error content" $ do + let [el] = testcase $/ element "error" + + it "strips escapes from a message attribute" $ do + -- Annoying, but Hspec has tied our hands here + (el $| attribute "type") `shouldBe` ["SomeException"] + (el $| attribute "message") `shouldBe` ["ColourfulException"] + + it "does not strip escapes in content" $ do + let [c] = el $/ content + + take 1 (T.lines c) `shouldBe` ["\ESC[32mColour\ESC[31mful\ESC[0mException"] + + context "ExampleSpec with prefixing" $ do + let testConfig' = setJUnitConfigSourcePathPrefix "lol/monorepo" testConfig + doc <- runIO $ fromDocument <$> renderJUnitXml testConfig' Example.spec + + it "prefixes testcase file attributes" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &| attribute "file" + ) + `shouldBe` replicate 6 ["lol/monorepo/tests/Example.hs"] + + context "ExampleSpec with dropConsoleFormatting" $ do + let testConfig' = setJUnitConfigDropConsoleFormatting True testConfig + doc <- runIO $ fromDocument <$> renderJUnitXml testConfig' Example.spec + + it "drops console formatting in text nodes" $ do + let [c] = + doc + $| element "testsuites" + &/ element "testsuite" + &/ element "testcase" + &/ element "error" + &/ content + + take 1 (T.lines c) `shouldBe` ["ColourfulException"] + +testConfig :: JUnitConfig +testConfig = defaultJUnitConfig "hspec-junit-format" + +renderJUnitXml :: JUnitConfig -> Spec -> IO XML.Document +renderJUnitXml baseConfig x = do + withSystemTempDirectory "" $ \tmp -> do + let junitConfig = + setJUnitConfigOutputDirectory tmp + $ setJUnitConfigOutputName "test.xml" baseConfig + + (config, forest) <- + Hspec.evalSpec Hspec.defaultConfig $ Formatter.use junitConfig x + + void $ Hspec.runSpecForest forest config + + XML.readFile XML.def $ tmp "test.xml" diff --git a/tests/golden/default-base-4.21.xml b/tests/golden/default-base-4.21.xml deleted file mode 100644 --- a/tests/golden/default-base-4.21.xml +++ /dev/null @@ -1,67 +0,0 @@ - - - - - - - tests/Example.hs:19:12 expected: "False" but got: "True" - - - - - - - - - tests/Example.hs:29:9 ColourfulException - - - - - tests/Example.hs:27:9 some reason - - - - - - diff --git a/tests/golden/default.xml b/tests/golden/default.xml deleted file mode 100644 --- a/tests/golden/default.xml +++ /dev/null @@ -1,67 +0,0 @@ - - - - - - - tests/Example.hs:19:12 expected: "False" but got: "True" - - - - - - - - - ColourfulException - - - - - tests/Example.hs:27:9 some reason - - - - - - diff --git a/tests/golden/prefixed-base-4.21.xml b/tests/golden/prefixed-base-4.21.xml deleted file mode 100644 --- a/tests/golden/prefixed-base-4.21.xml +++ /dev/null @@ -1,67 +0,0 @@ - - - - - - - lol/monorepo/tests/Example.hs:19:12 expected: "False" but got: "True" - - - - - - - - - lol/monorepo/tests/Example.hs:29:9 ColourfulException - - - - - lol/monorepo/tests/Example.hs:27:9 some reason - - - - - - diff --git a/tests/golden/prefixed.xml b/tests/golden/prefixed.xml deleted file mode 100644 --- a/tests/golden/prefixed.xml +++ /dev/null @@ -1,67 +0,0 @@ - - - - - - - lol/monorepo/tests/Example.hs:19:12 expected: "False" but got: "True" - - - - - - - - - ColourfulException - - - - - lol/monorepo/tests/Example.hs:27:9 some reason - - - - - -