diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -13,7 +13,6 @@ module Main (main) where import Prelude -import Text.Markdown.Unlit () -- Used in a later example import qualified Test.Hspec.JUnit.Formatter.Env as FormatterEnv @@ -119,6 +118,20 @@ We maintain specific golden XML files for GHC 8.x vs 9.x, so you will need to re-run the test suite with at least one of each series to regenerate all the necessary files. + +## Release + +To trigger a release, merge a commit to `main` that follows [Conventional +Commits][]. In short, + +- `fix:` to trigger a patch release +- `feat:` to trigger a minor release +- `!:` or use a `BREAKING CHANGE:` footer to trigger a major release + +We don't enforce conventional commits generally (though you are free do so), +it's only required if you want to trigger release. + +[conventional commits]: https://www.conventionalcommits.org/en/v1.0.0/#summary --- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,7 +13,6 @@ module Main (main) where import Prelude -import Text.Markdown.Unlit () -- Used in a later example import qualified Test.Hspec.JUnit.Formatter.Env as FormatterEnv @@ -119,6 +118,20 @@ We maintain specific golden XML files for GHC 8.x vs 9.x, so you will need to re-run the test suite with at least one of each series to regenerate all the necessary files. + +## Release + +To trigger a release, merge a commit to `main` that follows [Conventional +Commits][]. In short, + +- `fix:` to trigger a patch release +- `feat:` to trigger a minor release +- `!:` or use a `BREAKING CHANGE:` footer to trigger a major release + +We don't enforce conventional commits generally (though you are free do so), +it's only required if you want to trigger release. + +[conventional commits]: https://www.conventionalcommits.org/en/v1.0.0/#summary --- 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.1.2.1 -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-ghc-8.xml - tests/golden/default-ghc-9.xml - tests/golden/prefixed-ghc-8.xml - tests/golden/prefixed-ghc-9.xml - +category: Testing +build-type: Simple extra-doc-files: README.md CHANGELOG.md @@ -30,7 +24,6 @@ library exposed-modules: - Test.Hspec.JUnit Test.Hspec.JUnit.Config Test.Hspec.JUnit.Config.Env Test.Hspec.JUnit.Format @@ -41,87 +34,75 @@ hs-source-dirs: library other-modules: Paths_hspec_junit_formatter - default-language: Haskell2010 + default-language: GHC2021 default-extensions: - BangPatterns DeriveAnyClass DeriveFoldable DeriveFunctor - DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies - FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving - LambdaCase MultiParamTypeClasses NoImplicitPrelude - NoMonomorphismRestriction OverloadedStrings RankNTypes - RecordWildCards ScopedTypeVariables StandaloneDeriving - TypeApplications TypeFamilies + DataKinds DeriveAnyClass DerivingStrategies DerivingVia + DuplicateRecordFields GADTs LambdaCase NoFieldSelectors + NoImplicitPrelude NoMonomorphismRestriction NoPostfixOperators + OverloadedRecordDot OverloadedStrings QuasiQuotes TypeFamilies ghc-options: - -fignore-optim-changes -Weverything -Wno-all-missed-specialisations + -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures - -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe + -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe build-depends: - array >=0.5.2.0, - base >=4.11.1.0 && <5, - conduit >=1.3.1, - containers >=0.5.11.0, - directory >=1.3.1.5, - exceptions >=0.10.0, - filepath >=1.4.2, + array >=0.5.4.0, + base >=4.16.4.0 && <5, + conduit >=1.3.5, + directory >=1.3.6.2, + 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.2, - text >=1.2.3.1, - time >=1.8.0.2, - xml-conduit >=1.8.0.1, - xml-types >=0.3.6 + 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, + xml-types >=0.3.8 + if impl(ghc >=9.8) + ghc-options: -Wno-missing-role-annotations + if impl(ghc >=9.2) ghc-options: -Wno-missing-kind-signatures - if impl(ghc >=8.10) - ghc-options: - -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module - - if impl(ghc >=8.8) - ghc-options: -fwrite-ide-info - test-suite readme type: exitcode-stdio-1.0 main-is: README.lhs + build-tool-depends: markdown-unlit:markdown-unlit other-modules: Paths_hspec_junit_formatter - default-language: Haskell2010 + default-language: GHC2021 default-extensions: - BangPatterns DeriveAnyClass DeriveFoldable DeriveFunctor - DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies - FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving - LambdaCase MultiParamTypeClasses NoImplicitPrelude - NoMonomorphismRestriction OverloadedStrings RankNTypes - RecordWildCards ScopedTypeVariables StandaloneDeriving - TypeApplications TypeFamilies + DataKinds DeriveAnyClass DerivingStrategies DerivingVia + DuplicateRecordFields GADTs LambdaCase NoFieldSelectors + NoImplicitPrelude NoMonomorphismRestriction NoPostfixOperators + OverloadedRecordDot OverloadedStrings QuasiQuotes TypeFamilies ghc-options: - -fignore-optim-changes -Weverything -Wno-all-missed-specialisations + -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures - -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -pgmL + -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -pgmL markdown-unlit build-depends: - base >=4.11.1.0 && <5, + base >=4.16.4.0 && <5, hspec >=2.10.0, - hspec-junit-formatter, - markdown-unlit >=0.5.0 + hspec-junit-formatter + if impl(ghc >=9.8) + ghc-options: -Wno-missing-role-annotations + if impl(ghc >=9.2) ghc-options: -Wno-missing-kind-signatures - if impl(ghc >=8.10) - ghc-options: - -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module - - if impl(ghc >=8.8) - ghc-options: -fwrite-ide-info - test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs @@ -133,40 +114,33 @@ Test.Hspec.JUnit.FormatterSpec Paths_hspec_junit_formatter - default-language: Haskell2010 + default-language: GHC2021 default-extensions: - BangPatterns DeriveAnyClass DeriveFoldable DeriveFunctor - DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies - FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving - LambdaCase MultiParamTypeClasses NoImplicitPrelude - NoMonomorphismRestriction OverloadedStrings RankNTypes - RecordWildCards ScopedTypeVariables StandaloneDeriving - TypeApplications TypeFamilies + DataKinds DeriveAnyClass DerivingStrategies DerivingVia + DuplicateRecordFields GADTs LambdaCase NoFieldSelectors + NoImplicitPrelude NoMonomorphismRestriction NoPostfixOperators + OverloadedRecordDot OverloadedStrings QuasiQuotes TypeFamilies ghc-options: - -fignore-optim-changes -Weverything -Wno-all-missed-specialisations + -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures - -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded - -rtsopts -O0 -with-rtsopts=-N + -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded + -rtsopts -with-rtsopts=-N build-depends: - base >=4.11.1.0 && <5, - containers >=0.5.11.0, - filepath >=1.4.2, + base >=4.16.4.0 && <5, + filepath >=1.4.2.2, hspec >=2.10.0, - hspec-golden >=0.2.1.0, hspec-junit-formatter, + iso8601-time >=0.1.5, temporary >=1.3, - text >=1.2.3.1, - xml-conduit >=1.8.0.1 + text >=1.2.5.0, + xml-conduit >=1.10.0.0 + if impl(ghc >=9.8) + ghc-options: -Wno-missing-role-annotations + if impl(ghc >=9.2) ghc-options: -Wno-missing-kind-signatures - - if impl(ghc >=8.10) - ghc-options: - -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module - - if impl(ghc >=8.8) - ghc-options: -fwrite-ide-info diff --git a/library/Test/Hspec/JUnit.hs b/library/Test/Hspec/JUnit.hs deleted file mode 100644 --- a/library/Test/Hspec/JUnit.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Test.Hspec.JUnit - {-# DEPRECATED "Use Test.Hspec.JUnit.Formatter" #-} - ( -- * Runners - hspecJUnit - , hspecJUnitWith - - -- * Directly modifying 'Config' - , configWithJUnit - , configWithJUnitAvailable - - -- * Actual format function - , junitFormat - - -- * Configuration - , module Test.Hspec.JUnit.Config - ) where - -import Prelude - -import Control.Applicative ((<|>)) -import Data.Conduit (runConduitRes, (.|)) -import Data.Conduit.Combinators (sinkFile) -import Data.Conduit.List (sourceList) -import Data.Functor ((<&>)) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T -import Data.Time (getCurrentTime) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (splitFileName) -import Test.Hspec.Core.Format - ( Event (..) - , FailureReason (..) - , Format - , FormatConfig - , Item (..) - , Location (..) - , Path - , Result (..) - , Seconds (..) - ) -import Test.Hspec.Core.Runner (Config (..), defaultConfig, hspecWith) -import Test.Hspec.Core.Spec (Spec) -import Test.Hspec.JUnit.Config -import Test.Hspec.JUnit.Config.Env -import Test.Hspec.JUnit.Render (renderJUnit) -import qualified Test.Hspec.JUnit.Schema as Schema -import Text.XML.Stream.Render (def, renderBytes) - --- | Like 'hspec' but adds JUNit functionality --- --- To actually /use/ the JUnit format, you must set @JUNIT_ENABLED=1@ in the --- environment; by default, this function just behaves like 'hspec'. --- --- Running tests with @--test-arguments="-f junit"@ also works. --- --- All configuration of the JUnit report occurs through environment variables. --- --- See "Test.Hspec.JUnit.Config" and "Test.Hspec.JUnit.Config.Env". -hspecJUnit :: Spec -> IO () -hspecJUnit = hspecJUnitWith defaultConfig - --- | 'hspecJUnit' but built on a non-default 'Config' -hspecJUnitWith :: Config -> Spec -> IO () -hspecJUnitWith config spec = do - junitEnabled <- envJUnitEnabled - junitConfig <- envJUnitConfig - - let - modify = if junitEnabled then configWithJUnit junitConfig else id - base = configWithJUnitAvailable junitConfig config - - hspecWith (modify base) spec - --- | Modify an Hspec 'Config' to use 'junitFormat' -configWithJUnit :: JUnitConfig -> Config -> Config -configWithJUnit junitConfig config = - config {configFormat = Just $ junitFormat junitConfig} - --- | Modify an Hspec 'Config' to have the 'junitFormat' /available/ --- --- Adds @junit@ to the list of available options for @-f, --format@. -configWithJUnitAvailable :: JUnitConfig -> Config -> Config -configWithJUnitAvailable junitConfig config = - config - { configAvailableFormatters = - configAvailableFormatters config <> [("junit", junitFormat junitConfig)] - } - --- | Hspec 'configFormat' that generates a JUnit report -junitFormat :: JUnitConfig -> FormatConfig -> IO Format -junitFormat junitConfig _config = pure $ \case - Started -> pure () - GroupStarted _ -> pure () - GroupDone _ -> pure () - 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 - { suitesName = suiteName - , suitesSuites = - groups <&> \(group, items) -> do - let suite xs = - Schema.Suite - { suiteName = group - , suiteTimestamp = time - , suiteCases = xs - } - suite $ uncurry (itemToTestCase applyPrefix group) <$> items - } - - runConduitRes $ - sourceList [output] - .| renderJUnit dropConsoleFormatting - .| renderBytes def - .| sinkFile file - where - file = getJUnitConfigOutputFile junitConfig - suiteName = getJUnitConfigSuiteName junitConfig - applyPrefix = getJUnitPrefixSourcePath junitConfig - dropConsoleFormatting = getJUnitConfigDropConsoleFormatting junitConfig - -groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])] -groupItems = Map.toList . Map.fromListWith (<>) . fmap group - where - group ((path, name), item) = - (T.intercalate "/" $ pack <$> path, [(pack name, item)]) - -itemToTestCase - :: (FilePath -> FilePath) -> Text -> Text -> Item -> Schema.TestCase -itemToTestCase applyPrefix group name item = - Schema.TestCase - { testCaseLocation = - toSchemaLocation applyPrefix - <$> (itemResultLocation item <|> itemLocation item) - , testCaseClassName = group - , testCaseName = name - , testCaseDuration = unSeconds $ itemDuration item - , testCaseResult = 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 - } - where - prefixLocation mLocation str = case mLocation of - Nothing -> str - Just Location {..} -> - mconcat - [ pack $ applyPrefix locationFile - , ":" - , pack $ show locationLine - , ":" - , pack $ show locationColumn - , "\n" - ] - <> str - prefixInfo str - | T.null $ T.strip $ pack $ itemInfo item = str - | otherwise = pack (itemInfo item) <> "\n\n" <> str - -itemResultLocation :: Item -> Maybe Location -itemResultLocation item = case itemResult item of - Success -> Nothing - Pending mLocation _ -> mLocation - Failure mLocation _ -> mLocation - -toSchemaLocation :: (FilePath -> FilePath) -> Location -> Schema.Location -toSchemaLocation applyPrefix Location {..} = - Schema.Location - { Schema.locationFile = applyPrefix locationFile - , Schema.locationLine = fromIntegral $ max 0 locationLine - } - -unSeconds :: Seconds -> Double -unSeconds (Seconds x) = x - -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 - -{- FOURMOLU_DISABLE -} -reasonToText :: FailureReason -> Text -reasonToText = \case - Error _ err -> pack $ show err - NoReason -> "no reason" - Reason err -> pack err -#if MIN_VERSION_hspec_core(2,11,0) - ColorizedReason err -> pack err -#endif - ExpectedButGot preface expected actual -> - T.unlines - $ pack - <$> fromMaybe "" preface - : (foundLines "expected" expected - <> foundLines " but got" actual - ) -{- FOURMOLU_ENABLE -} diff --git a/library/Test/Hspec/JUnit/Config.hs b/library/Test/Hspec/JUnit/Config.hs --- a/library/Test/Hspec/JUnit/Config.hs +++ b/library/Test/Hspec/JUnit/Config.hs @@ -9,12 +9,14 @@ , setJUnitConfigSuiteName , setJUnitConfigSourcePathPrefix , setJUnitConfigDropConsoleFormatting + , setJUnitConfigPretty -- * Use , getJUnitConfigOutputFile , getJUnitConfigSuiteName , getJUnitPrefixSourcePath , getJUnitConfigDropConsoleFormatting + , getJUnitConfigPretty ) where import Prelude @@ -24,12 +26,13 @@ import System.FilePath (()) data JUnitConfig = JUnitConfig - { junitConfigOutputDirectory :: FilePath - , junitConfigOutputName :: FilePath - , junitConfigOutputFile :: Maybe FilePath - , junitConfigSuiteName :: Text - , junitConfigSourcePathPrefix :: Maybe FilePath - , junitConfigDropConsoleFormatting :: Bool + { outputDirectory :: FilePath + , outputName :: FilePath + , outputFile :: Maybe FilePath + , suiteName :: Text + , sourcePathPrefix :: Maybe FilePath + , dropConsoleFormatting :: Bool + , pretty :: Bool } -- | Construct a 'JUnitConfig' given a suite name @@ -38,35 +41,35 @@ defaultJUnitConfig :: Text -> JUnitConfig defaultJUnitConfig name = JUnitConfig - { junitConfigOutputDirectory = "." - , junitConfigOutputName = "junit.xml" - , junitConfigOutputFile = Nothing - , junitConfigSuiteName = name - , junitConfigSourcePathPrefix = Nothing - , junitConfigDropConsoleFormatting = False + { outputDirectory = "." + , outputName = "junit.xml" + , outputFile = Nothing + , suiteName = name + , sourcePathPrefix = Nothing + , dropConsoleFormatting = False + , pretty = False } -- | Set the directory within which to generate the report -- -- Default is current working directory. setJUnitConfigOutputDirectory :: FilePath -> JUnitConfig -> JUnitConfig -setJUnitConfigOutputDirectory x config = - config {junitConfigOutputDirectory = x} +setJUnitConfigOutputDirectory x config = config {outputDirectory = x} -- | Set the name for the generated report -- -- Default is @junit.xml@. setJUnitConfigOutputName :: FilePath -> JUnitConfig -> JUnitConfig -setJUnitConfigOutputName x config = config {junitConfigOutputName = x} +setJUnitConfigOutputName x config = config {outputName = x} -- | Set the full path to the generated report -- -- If given, the directory and name configurations are ignored. setJUnitConfigOutputFile :: FilePath -> JUnitConfig -> JUnitConfig -setJUnitConfigOutputFile x config = config {junitConfigOutputFile = Just x} +setJUnitConfigOutputFile x config = config {outputFile = Just x} setJUnitConfigSuiteName :: Text -> JUnitConfig -> JUnitConfig -setJUnitConfigSuiteName x config = config {junitConfigSuiteName = x} +setJUnitConfigSuiteName x config = config {suiteName = x} -- | Set a prefix to apply to source paths in the report -- @@ -74,8 +77,7 @@ -- in a monorepository, and you need reported paths to be from the repository -- root. setJUnitConfigSourcePathPrefix :: FilePath -> JUnitConfig -> JUnitConfig -setJUnitConfigSourcePathPrefix x config = - config {junitConfigSourcePathPrefix = Just x} +setJUnitConfigSourcePathPrefix x config = config {sourcePathPrefix = Just x} -- | Set whether console formatting characters should be dropped from failure -- reports. @@ -83,27 +85,36 @@ -- Default is False. Most XML processors will fail to parse the XML if it -- contains the ANSI control characters used by console formatting. setJUnitConfigDropConsoleFormatting :: Bool -> JUnitConfig -> JUnitConfig -setJUnitConfigDropConsoleFormatting x config = config {junitConfigDropConsoleFormatting = x} +setJUnitConfigDropConsoleFormatting x config = config {dropConsoleFormatting = x} +-- | Set whether the file should be pretty-printed +-- +-- @xml-conduit@ can pretty-print the contents of the XML file in order to make +-- it more human-readable. Note that this operation normalizes whitespace even +-- within nodes. This may turn multi-line failure messages into one line, for +-- example. +setJUnitConfigPretty :: Bool -> JUnitConfig -> JUnitConfig +setJUnitConfigPretty x config = config {pretty = x} + -- | Retrieve the full path to the generated report getJUnitConfigOutputFile :: JUnitConfig -> FilePath -getJUnitConfigOutputFile JUnitConfig {..} = - fromMaybe - (junitConfigOutputDirectory junitConfigOutputName) - junitConfigOutputFile +getJUnitConfigOutputFile c = fromMaybe (c.outputDirectory c.outputName) c.outputFile -- | Retrieve the suite name given on construction getJUnitConfigSuiteName :: JUnitConfig -> Text -getJUnitConfigSuiteName = junitConfigSuiteName +getJUnitConfigSuiteName c = c.suiteName -- | Retrieve the function to apply to reported source paths -- -- Will be 'id' if no prefix configured. getJUnitPrefixSourcePath :: JUnitConfig -> FilePath -> FilePath -getJUnitPrefixSourcePath JUnitConfig {..} = - maybe id () junitConfigSourcePathPrefix +getJUnitPrefixSourcePath c = maybe id () c.sourcePathPrefix -- | Retrieve whether console formatting characters should be dropped from -- failure reports. getJUnitConfigDropConsoleFormatting :: JUnitConfig -> Bool -getJUnitConfigDropConsoleFormatting JUnitConfig {..} = junitConfigDropConsoleFormatting +getJUnitConfigDropConsoleFormatting c = c.dropConsoleFormatting + +-- | Retrieve whether the file should be pretty-printed +getJUnitConfigPretty :: JUnitConfig -> Bool +getJUnitConfigPretty c = c.pretty diff --git a/library/Test/Hspec/JUnit/Config/Env.hs b/library/Test/Hspec/JUnit/Config/Env.hs --- a/library/Test/Hspec/JUnit/Config/Env.hs +++ b/library/Test/Hspec/JUnit/Config/Env.hs @@ -11,7 +11,7 @@ import Data.Semigroup (Endo (..)) import Data.Text (pack, unpack) -import qualified Data.Text as T +import Data.Text qualified as T import System.Directory (getCurrentDirectory) import System.Environment (getEnvironment, lookupEnv) import System.FilePath (takeBaseName) @@ -42,16 +42,17 @@ readJUnitConfig base env = modify $ defaultJUnitConfig $ pack base where modify = - appEndo $ - foldMap + appEndo + $ foldMap Endo [ readEnv "OUTPUT_DIRECTORY" setJUnitConfigOutputDirectory , readEnv "OUTPUT_NAME" setJUnitConfigOutputName , readEnv "OUTPUT_FILE" setJUnitConfigOutputFile , readEnv "SUITE_NAME" $ setJUnitConfigSuiteName . pack , readEnv "SOURCE_PATH_PREFIX" setJUnitConfigSourcePathPrefix - , readEnv "DROP_CONSOLE_FORMATTING" $ - setJUnitConfigDropConsoleFormatting . (== "1") + , readEnv "DROP_CONSOLE_FORMATTING" + $ setJUnitConfigDropConsoleFormatting . (== "1") + , readEnv "PRETTY" $ setJUnitConfigPretty . (== "1") ] readEnv name setter = 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,26 +1,42 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + module Test.Hspec.JUnit.Format ( junit ) where import Prelude +import Conduit import Control.Applicative ((<|>)) -import Data.Conduit (runConduitRes, (.|)) -import Data.Conduit.Combinators (sinkFile) -import Data.Conduit.List (sourceList) -import Data.Functor ((<&>)) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack, unpack) -import qualified Data.Text 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 qualified Test.Hspec.JUnit.Schema 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) junit :: JUnitConfig -> FormatConfig -> IO Format junit junitConfig _config = pure $ \case @@ -30,123 +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 - { suitesName = suiteName - , suitesSuites = - groups <&> \(group, items) -> do - let suite xs = - Schema.Suite - { suiteName = group - , suiteTimestamp = time - , suiteCases = xs - } - suite $ uncurry (itemToTestCase applyPrefix group) <$> items - } - - runConduitRes $ - sourceList [output] - .| renderJUnit dropConsoleFormatting - .| renderBytes def + Done items -> do + now <- getCurrentTime + createDirectoryIfMissing True $ takeDirectory file + runConduitRes + $ 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 - { testCaseLocation = - toSchemaLocation applyPrefix - <$> (itemResultLocation item <|> itemLocation item) - , testCaseClassName = group - , testCaseName = name - , testCaseDuration = unSeconds $ itemDuration item - , testCaseResult = 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 Location {..} -> - mconcat - [ pack $ applyPrefix locationFile - , ":" - , pack $ show locationLine - , ":" - , pack $ show locationColumn - , "\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 Location {..} = - Schema.Location - { Schema.locationFile = applyPrefix locationFile - , Schema.locationLine = fromIntegral $ max 0 locationLine + 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/Formatter.hs b/library/Test/Hspec/JUnit/Formatter.hs --- a/library/Test/Hspec/JUnit/Formatter.hs +++ b/library/Test/Hspec/JUnit/Formatter.hs @@ -8,7 +8,7 @@ -- import Test.Hspec.JUnit.Config -- import Test.Hspec.JUnit.Formatter qualified as Formatter -- --- -- | To only produce a JUnit file, silencing other output +-- -- | To produce only a JUnit file, silencing other output -- hook :: Spec -> Spec -- hook = Formatter.use defaultJUnitConfig -- @@ -16,7 +16,7 @@ -- hook :: Spec -> Spec -- hook = Formatter.add defaultJUnitConfig -- --- -- | To only produce, but only when @--format=junit@ is used +-- -- | To produce only a JUnit file, and only when @--format=junit@ is used -- hook :: Spec -> Spec -- hook = Formatter.register defaultJUnitConfig -- @ @@ -40,10 +40,9 @@ import Prelude import Data.Maybe (fromMaybe) - import Test.Hspec.Api.Format.V1 as Api -import qualified Test.Hspec.Core.Format as Core -import qualified Test.Hspec.Core.Formatters.V2 as V2 +import Test.Hspec.Core.Format qualified as Core +import Test.Hspec.Core.Formatters.V2 qualified as V2 import Test.Hspec.Core.Runner as Core (Config (..)) import Test.Hspec.JUnit.Config import Test.Hspec.JUnit.Format diff --git a/library/Test/Hspec/JUnit/Formatter/Env.hs b/library/Test/Hspec/JUnit/Formatter/Env.hs --- a/library/Test/Hspec/JUnit/Formatter/Env.hs +++ b/library/Test/Hspec/JUnit/Formatter/Env.hs @@ -30,7 +30,7 @@ import Test.Hspec.Core.Spec (runIO) import Test.Hspec.JUnit.Config import Test.Hspec.JUnit.Config.Env -import qualified Test.Hspec.JUnit.Formatter as JUnit +import Test.Hspec.JUnit.Formatter qualified as JUnit whenEnabled :: (SpecWith a -> SpecWith a) -> SpecWith a -> SpecWith a whenEnabled hook spec = do 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,112 +1,215 @@ module Test.Hspec.JUnit.Render - ( renderJUnit + ( renderTestsuites ) where import Prelude -import Control.Monad.Catch (MonadThrow) -import qualified Data.Array as Array -import Data.Conduit (ConduitT, awaitForever, mergeSource, yield, (.|)) -import qualified Data.Conduit.List as CL +import Conduit (ConduitT) +import Control.Monad (unless) +import Control.Monad.Reader (MonadReader (..), asks) +import Data.Array qualified as Array +import Data.Fixed (Nano) import Data.Foldable (traverse_) +import Data.Semigroup (Endo (..)) import Data.Text (Text, pack) -import qualified Data.Text 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 qualified Text.Regex.Base as Regex -import qualified Text.Regex.TDFA.Text as Regex -import Text.XML.Stream.Render (attr, content, tag) +import Text.Regex.Base qualified as Regex +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 $ \Suites {..} -> - tag "testsuites" (attr "name" suitesName) $ - CL.sourceList suitesSuites - .| 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, theSuite@Suite {..}) -> - tag "testsuite" (attributes i theSuite) $ do - tag "properties" mempty mempty - CL.sourceList suiteCases .| do - awaitForever $ \x -> yield x .| testCase shouldDropConsoleFormatting - where - -- TODO these need to be made real values - attributes i Suite {..} = - attr "name" suiteName - <> attr "package" suiteName - <> attr "id" (tshow i) - <> attr "time" (roundToStr $ sumDurations suiteCases) - <> attr "timestamp" (pack $ formatISO8601 suiteTimestamp) - <> attr "hostname" "localhost" - <> attr "tests" (tshow $ length suiteCases) - <> attr - "failures" - ( tshow $ - length [() | Just Failure {} <- testCaseResult <$> suiteCases] - ) - <> attr "errors" "0" - <> attr - "skipped" - ( tshow $ - length [() | Just Skipped {} <- testCaseResult <$> suiteCases] - ) +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 . locationFile) mLocation - <> maybe mempty (attr "line" . pack . show . locationLine) 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 $ testCaseDuration <$> 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 - { suitesName :: Text - , suitesSuites :: [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 - { suiteName :: Text - , suiteTimestamp :: UTCTime - , suiteCases :: [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 - { testCaseLocation :: Maybe Location - , testCaseClassName :: Text - , testCaseName :: Text - , testCaseDuration :: Double - , testCaseResult :: 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 - { locationFile :: FilePath - , locationLine :: 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/Example.hs b/tests/Example.hs --- a/tests/Example.hs +++ b/tests/Example.hs @@ -5,9 +5,9 @@ -- In fact, this sentence was added to retain them across a formatting change. module Example (spec) where -import Control.Exception import Prelude +import Control.Exception import Test.Hspec spec :: Spec 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,112 +7,331 @@ import Prelude import Control.Monad (void) -import Data.Char (isSpace) -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import qualified Example -import System.FilePath ((<.>), ()) +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.IO.Temp (withSystemTempDirectory) import Test.Hspec -import Test.Hspec.Golden import Test.Hspec.JUnit.Config -import qualified Test.Hspec.JUnit.Formatter as Formatter -import Test.Hspec.Runner -import qualified Text.XML as XML +import Test.Hspec.JUnit.Formatter qualified as Formatter +import Test.Hspec.Runner qualified as Hspec +import Text.Read (readMaybe) +import Text.XML qualified as XML +import Text.XML.Cursor spec :: Spec spec = do - it "matches golden file" $ - junitGolden "default" id + context "ExampleSpec" $ do + doc <- runIO $ fromDocument <$> renderJUnitXml testConfig Example.spec - it "matches golden file with prefixing" $ - 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 $ - 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 = show - , writeToFile = XML.writeFile XML.def - , readFromFile = readNormalizedXML - , goldenFile = - "tests" "golden" name <> "-" <> ghcSuffix <.> "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 = removeWhitespaceNodes . 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" -removeWhitespaceNodes :: XML.Document -> XML.Document -removeWhitespaceNodes doc = - doc - { XML.documentRoot = go $ XML.documentRoot doc - } - where - go el = - el {XML.elementNodes = concatMap filterWhitespace $ XML.elementNodes el} + [suite1Timestamp, suite2Timestamp] = + concatMap (map (parseISO8601 . unpack)) + $ doc + $| element "testsuites" + &/ element "testsuite" + &| attribute "timestamp" - filterWhitespace :: XML.Node -> [XML.Node] - filterWhitespace = \case - XML.NodeElement el -> [XML.NodeElement $ go el] - XML.NodeContent c | T.all isSpace c -> [] - n -> [n] + suitesTimestamp `shouldSatisfy` isJust + suite1Timestamp `shouldSatisfy` isJust + suite2Timestamp `shouldSatisfy` isJust + suite1Timestamp `shouldBe` suitesTimestamp + suite2Timestamp `shouldBe` suitesTimestamp --- | Remove volatile attributes so they don't invalidate comparison -removeTimeAttributes :: XML.Document -> XML.Document -removeTimeAttributes = - removeAttributesByName "time" . removeAttributesByName "timestamp" + context "testsuites node" $ do + it "produces one, with our package name" $ do + ( doc + $| element "testsuites" + &| attribute "name" + ) + `shouldBe` [["hspec-junit-format"]] -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 - } + context "testsuite nodes" $ do + it "produces two" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + ) + `shouldSatisfy` (== 2) . length - onNodeElement f = \case - XML.NodeElement el -> XML.NodeElement $ f el - n -> n + it "has name" $ do + ( doc + $| element "testsuites" + &/ element "testsuite" + &| attribute "name" + ) + `shouldBe` [ ["Some section"] + , ["Some section/A grouped context"] + ] --- GHC can change certain aspects, mainly about source-location, so we can --- incorpate that by tracking separate Golden files as necessary -ghcSuffix :: String -#if __GLASGOW_HASKELL__ >= 900 -ghcSuffix = "ghc-9" -#elif __GLASGOW_HASKELL__ >= 800 -ghcSuffix = "ghc-8" -#else --- Fail to compile on other GHCs -#endif + 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-ghc-8.xml b/tests/golden/default-ghc-8.xml deleted file mode 100644 --- a/tests/golden/default-ghc-8.xml +++ /dev/null @@ -1,69 +0,0 @@ - - - - - tests/Example.hs:19:7 - -expected: "False" - but got: "True" - - - - - - - - ColourfulException - - - tests/Example.hs:27:9 -some reason - - - - - diff --git a/tests/golden/default-ghc-9.xml b/tests/golden/default-ghc-9.xml deleted file mode 100644 --- a/tests/golden/default-ghc-9.xml +++ /dev/null @@ -1,6 +0,0 @@ -tests/Example.hs:19:12 - -expected: "False" - but got: "True" -ColourfulExceptiontests/Example.hs:27:9 -some reason diff --git a/tests/golden/prefixed-ghc-8.xml b/tests/golden/prefixed-ghc-8.xml deleted file mode 100644 --- a/tests/golden/prefixed-ghc-8.xml +++ /dev/null @@ -1,69 +0,0 @@ - - - - - lol/monorepo/tests/Example.hs:19:7 - -expected: "False" - but got: "True" - - - - - - - - ColourfulException - - - lol/monorepo/tests/Example.hs:27:9 -some reason - - - - - diff --git a/tests/golden/prefixed-ghc-9.xml b/tests/golden/prefixed-ghc-9.xml deleted file mode 100644 --- a/tests/golden/prefixed-ghc-9.xml +++ /dev/null @@ -1,69 +0,0 @@ - - - - - lol/monorepo/tests/Example.hs:19:12 - -expected: "False" - but got: "True" - - - - - - - - ColourfulException - - - lol/monorepo/tests/Example.hs:27:9 -some reason - - - - -