diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ -## [_Unreleased_](https://github.com/freckle/hspec-junit-formatter/compare/v1.0.0.4...main) +## [_Unreleased_](https://github.com/freckle/hspec-junit-formatter/compare/v1.0.2.0...main) None + +## [v1.0.2.0](https://github.com/freckle/hspec-junit-formatter/compare/v1.0.1.0...v1.0.2.0) + +- Create `Test.Hspec` module-space and deprecate misspelled `Test.HSpec` modules +- Introduce `configWithJUnit` and `JUnitConfig` ## [v1.0.1.0](https://github.com/freckle/hspec-junit-formatter/compare/v1.0.0.4...v1.0.1.0) diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,36 @@ +# hspec-junit-formatter + +A `JUnit` XML runner/formatter for [`hspec`](http://hspec.github.io/). + + + +## Usage + +```haskell +import Test.Hspec +import Test.Hspec.Core.Runner (defaultConfig, hspecWith) +import Test.Hspec.JUnit + +main :: IO () +main = do + let + junitConfig = setJUnitConfigOutputDirectory "/tmp" $ defaultJUnitConfig "my-tests" + hspecConfig = configWithJUnit junitConfig defaultConfig + + hspecWith hspecConfig spec + +spec :: Spec +spec = describe "Addition" $ do + it "adds" $ do + 2 + 2 `shouldBe` (4 :: Int) +``` + +--- + +[LICENSE](./LICENSE) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,9 +2,35 @@ A `JUnit` XML runner/formatter for [`hspec`](http://hspec.github.io/). -```hs + + +## Usage + +```haskell +import Test.Hspec +import Test.Hspec.Core.Runner (defaultConfig, hspecWith) +import Test.Hspec.JUnit + main :: IO () main = do - config <- readConfig defaultConfig =<< getArgs - spec `runJUnitSpec` ("output-dir", "my-tests-title") $ config + let + junitConfig = setJUnitConfigOutputDirectory "/tmp" $ defaultJUnitConfig "my-tests" + hspecConfig = configWithJUnit junitConfig defaultConfig + + hspecWith hspecConfig spec + +spec :: Spec +spec = describe "Addition" $ do + it "adds" $ do + 2 + 2 `shouldBe` (4 :: Int) ``` + +--- + +[LICENSE](./LICENSE) diff --git a/hspec-junit-formatter.cabal b/hspec-junit-formatter.cabal --- a/hspec-junit-formatter.cabal +++ b/hspec-junit-formatter.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: hspec-junit-formatter -version: 1.0.1.0 +version: 1.0.2.0 license: MIT license-file: LICENSE copyright: 2021 Renaissance Learning Inc @@ -25,8 +25,12 @@ library exposed-modules: Test.HSpec.JUnit + Test.Hspec.JUnit + Test.Hspec.JUnit.Config Test.HSpec.JUnit.Render + Test.Hspec.JUnit.Render Test.HSpec.JUnit.Schema + Test.Hspec.JUnit.Schema hs-source-dirs: library other-modules: Paths_hspec_junit_formatter @@ -53,11 +57,36 @@ xml-conduit >=1.9.1.1, xml-types >=0.3.8 +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + other-modules: Paths_hspec_junit_formatter + default-language: Haskell2010 + 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 + + ghc-options: -pgmL markdown-unlit + build-depends: + base >=4.14.1.0 && <5, + hspec >=2.8.1, + hspec-core >=2.8.1, + hspec-junit-formatter -any, + markdown-unlit >=0.5.1 + test-suite spec type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: tests - other-modules: Paths_hspec_junit_formatter + other-modules: + ExampleSpec + Paths_hspec_junit_formatter + default-language: Haskell2010 default-extensions: BangPatterns DeriveAnyClass DeriveFoldable DeriveFunctor @@ -71,5 +100,9 @@ ghc-options: -threaded -rtsopts -O0 -with-rtsopts=-N build-depends: base >=4.14.1.0 && <5, + containers >=0.6.2.1, + filepath >=1.4.2.1, hspec >=2.8.1, - hspec-junit-formatter -any + hspec-junit-formatter -any, + temporary >=1.3, + xml-conduit >=1.9.1.1 diff --git a/library/Test/HSpec/JUnit.hs b/library/Test/HSpec/JUnit.hs --- a/library/Test/HSpec/JUnit.hs +++ b/library/Test/HSpec/JUnit.hs @@ -1,4 +1,5 @@ module Test.HSpec.JUnit + {-# DEPRECATED "Use Test.Hspec.JUnit instead" #-} ( junitFormat , runJUnitSpec , configWith @@ -6,23 +7,12 @@ import Prelude -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) -import qualified Data.Text as T -import Data.Time (getCurrentTime) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (splitFileName) -import Test.HSpec.JUnit.Render (renderJUnit) -import qualified Test.HSpec.JUnit.Schema as Schema +import Data.Text (pack) import Test.Hspec.Core.Format import Test.Hspec.Core.Runner import Test.Hspec.Core.Spec (Spec) -import Text.XML.Stream.Render (def, renderBytes) +import Test.Hspec.JUnit hiding (junitFormat) +import qualified Test.Hspec.JUnit as JUnit runJUnitSpec :: Spec -> (FilePath, String) -> Config -> IO Summary runJUnitSpec spec (path, name) config = @@ -30,107 +20,15 @@ where filePath = path <> "/" <> name <> "/test_results.xml" configWith :: FilePath -> String -> Config -> Config -configWith filePath name config = - config { configFormat = Just $ junitFormat filePath name } - --- | Output `hspec` results as a `JUnit` `XML` file. -junitFormat - :: FilePath -- ^ File path for resulting xml file. E.G. `my-dir/output.xml` - -> String -- ^ Name of the test suite - -> FormatConfig - -> IO Format -junitFormat file suiteName _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 - let - output = Schema.Suites - { suitesName = T.pack suiteName - , suitesSuites = groups <&> \(group, items) -> do - let - suite xs = Schema.Suite - { suiteName = group - , suiteTimestamp = time - , suiteCases = xs - } - suite $ uncurry (itemToTestCase group) <$> items - } - runConduitRes - $ sourceList [output] - .| renderJUnit - .| renderBytes def - .| sinkFile file - -groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])] -groupItems = Map.toList . Map.fromListWith (<>) . fmap group - where - group ((path, name), item) = - (T.intercalate "/" $ T.pack <$> path, [(T.pack name, item)]) - -itemToTestCase :: Text -> Text -> Item -> Schema.TestCase -itemToTestCase group name item = Schema.TestCase - { 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 - "" - T.pack - mMessage - Failure mLocation reason -> - Just - $ Schema.Failure "error" - $ prefixLocation mLocation - $ prefixInfo - $ case reason of - Error _ err -> T.pack $ show err - NoReason -> "no reason" - Reason err -> T.pack err - ExpectedButGot preface expected actual -> - prefixInfo - $ T.unlines - $ T.pack - <$> fromMaybe "" preface - : (foundLines "expected" expected - <> foundLines " but got" actual - ) - } - where - prefixLocation mLocation str = case mLocation of - Nothing -> str - Just Location {..} -> - T.concat - [ T.pack locationFile - , ":" - , T.pack $ show locationLine - , ":" - , T.pack $ show locationColumn - , "\n" - ] - <> str - prefixInfo str - | T.null $ T.strip $ T.pack $ itemInfo item = str - | otherwise = T.pack (itemInfo item) <> "\n\n" <> str - -unSeconds :: Seconds -> Double -unSeconds (Seconds x) = x +configWith filePath = + configWithJUnit + . setJUnitConfigOutputFile filePath + . defaultJUnitConfig + . pack -foundLines :: Show a => Text -> a -> [String] -foundLines msg found = case lines' of - [] -> [] - first : rest -> - T.unpack (msg <> ": " <> first) - : (T.unpack . (T.replicate 9 " " <>) <$> rest) - where lines' = T.lines . T.pack $ show found +junitFormat :: FilePath -> String -> FormatConfig -> IO Format +junitFormat filePath = + JUnit.junitFormat + . setJUnitConfigOutputFile filePath + . defaultJUnitConfig + . pack 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,79 +1,6 @@ module Test.HSpec.JUnit.Render + {-# DEPRECATED "Use Test.Hspec.JUnit.Render instead" #-} ( renderJUnit ) where -import Prelude - -import Control.Monad.Catch (MonadThrow) -import Data.Conduit (ConduitT, awaitForever, mergeSource, yield, (.|)) -import qualified Data.Conduit.List as CL -import Data.Foldable (traverse_) -import Data.Text (Text, pack) -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.XML.Types (Event) -import Test.HSpec.JUnit.Schema (Result(..), Suite(..), Suites(..), TestCase(..)) -import Text.Printf -import Text.XML.Stream.Render (attr, content, tag) - -renderJUnit :: MonadThrow m => ConduitT Suites Event m () -renderJUnit = awaitForever $ \Suites {..} -> - tag "testsuites" (attr "name" suitesName) - $ CL.sourceList suitesSuites - .| mergeSource idStream - .| suite - where idStream = CL.iterate (+ 1) 0 - -suite :: MonadThrow m => ConduitT (Int, Suite) Event m () -suite = awaitForever $ \(i, theSuite@Suite {..}) -> - tag "testsuite" (attributes i theSuite) $ do - tag "properties" mempty mempty - CL.sourceList suiteCases .| do - awaitForever $ \x -> yield x .| testCase - 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 $ iso8601Show 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 ] - ) - -tshow :: Show a => a -> Text -tshow = pack . show - -testCase :: MonadThrow m => ConduitT TestCase Event m () -testCase = awaitForever $ \(TestCase className name duration mResult) -> - tag "testcase" (attributes className name duration) - $ traverse_ yield mResult - .| result - where - attributes className name duration = - attr "name" name <> attr "classname" className <> attr - "time" - (roundToStr duration) - -result :: MonadThrow m => ConduitT Result Event m () -result = awaitForever go - where - go (Failure fType contents) = - tag "failure" (attr "type" fType) $ content contents - go (Skipped contents) = tag "skipped" mempty $ content contents - -sumDurations :: [TestCase] -> Double -sumDurations cases = sum $ testCaseDuration <$> cases - -roundToStr :: (PrintfArg a) => a -> Text -roundToStr = pack . printf "%0.9f" +import Test.Hspec.JUnit.Render 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,35 +1,9 @@ module Test.HSpec.JUnit.Schema + {-# DEPRECATED "Use Test.Hspec.JUnit.Schema instead" #-} ( Suites(..) , Suite(..) , TestCase(..) , Result(..) ) where -import Prelude - -import Data.Text (Text) -import Data.Time (UTCTime) - -data Suites = Suites - { suitesName :: Text - , suitesSuites :: [Suite] - } - deriving stock Show - -data Suite = Suite - { suiteName :: Text - , suiteTimestamp :: UTCTime - , suiteCases :: [TestCase] - } - deriving stock Show - -data TestCase = TestCase - { testCaseClassName :: Text - , testCaseName :: Text - , testCaseDuration :: Double - , testCaseResult :: Maybe Result - } - deriving stock Show - -data Result = Failure Text Text | Skipped Text - deriving stock Show +import Test.Hspec.JUnit.Schema diff --git a/library/Test/Hspec/JUnit.hs b/library/Test/Hspec/JUnit.hs new file mode 100644 --- /dev/null +++ b/library/Test/Hspec/JUnit.hs @@ -0,0 +1,133 @@ +module Test.Hspec.JUnit + ( configWithJUnit + , junitFormat + + -- * Configuration + , module Test.Hspec.JUnit.Config + ) where + +import Prelude + +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 +import Test.Hspec.Core.Runner +import Test.Hspec.JUnit.Config +import Test.Hspec.JUnit.Render (renderJUnit) +import qualified Test.Hspec.JUnit.Schema as Schema +import Text.XML.Stream.Render (def, renderBytes) + +-- | Modify an Hspec 'Config' to use 'junitFormat' +configWithJUnit :: JUnitConfig -> Config -> Config +configWithJUnit junitConfig config = + config { configFormat = Just $ 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 group) <$> items + } + + runConduitRes + $ sourceList [output] + .| renderJUnit + .| renderBytes def + .| sinkFile file + where + file = getJUnitConfigOutputFile junitConfig + suiteName = getJUnitConfigSuiteName 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 :: Text -> Text -> Item -> Schema.TestCase +itemToTestCase group name item = Schema.TestCase + { 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 + $ case reason of + Error _ err -> pack $ show err + NoReason -> "no reason" + Reason err -> pack err + ExpectedButGot preface expected actual -> + prefixInfo + $ T.unlines + $ pack + <$> fromMaybe "" preface + : (foundLines "expected" expected + <> foundLines " but got" actual + ) + } + where + prefixLocation mLocation str = case mLocation of + Nothing -> str + Just Location {..} -> + mconcat + [ pack 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 + +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 diff --git a/library/Test/Hspec/JUnit/Config.hs b/library/Test/Hspec/JUnit/Config.hs new file mode 100644 --- /dev/null +++ b/library/Test/Hspec/JUnit/Config.hs @@ -0,0 +1,70 @@ +module Test.Hspec.JUnit.Config + ( JUnitConfig + + -- * Construction + , defaultJUnitConfig + , setJUnitConfigOutputDirectory + , setJUnitConfigOutputName + , setJUnitConfigOutputFile + + -- * Use + , getJUnitConfigOutputFile + , getJUnitConfigSuiteName + ) where + +import Prelude + +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import System.FilePath (()) + +data JUnitConfig = JUnitConfig + { junitConfigOutputDirectory :: FilePath + , junitConfigOutputName :: FilePath + , junitConfigOutputFile :: Maybe FilePath + , junitConfigSuiteName :: Text + } + +-- | Construct a 'JUnitConfig' given a suite name +-- +-- See individual set functions for defaults. +-- +defaultJUnitConfig :: Text -> JUnitConfig +defaultJUnitConfig name = JUnitConfig + { junitConfigOutputDirectory = "." + , junitConfigOutputName = "junit.xml" + , junitConfigOutputFile = Nothing + , junitConfigSuiteName = name + } + +-- | Set the directory within which to generate the report +-- +-- Default is current working directory. +-- +setJUnitConfigOutputDirectory :: FilePath -> JUnitConfig -> JUnitConfig +setJUnitConfigOutputDirectory x config = + config { junitConfigOutputDirectory = x } + +-- | Set the name for the generated report +-- +-- Default is @junit.xml@. +-- +setJUnitConfigOutputName :: FilePath -> JUnitConfig -> JUnitConfig +setJUnitConfigOutputName x config = config { junitConfigOutputName = 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 } + +-- | Retrieve the full path to the generated report +getJUnitConfigOutputFile :: JUnitConfig -> FilePath +getJUnitConfigOutputFile JUnitConfig {..} = fromMaybe + (junitConfigOutputDirectory junitConfigOutputName) + junitConfigOutputFile + +-- | Retrieve the suite name given on construction +getJUnitConfigSuiteName :: JUnitConfig -> Text +getJUnitConfigSuiteName = junitConfigSuiteName diff --git a/library/Test/Hspec/JUnit/Render.hs b/library/Test/Hspec/JUnit/Render.hs new file mode 100644 --- /dev/null +++ b/library/Test/Hspec/JUnit/Render.hs @@ -0,0 +1,79 @@ +module Test.Hspec.JUnit.Render + ( renderJUnit + ) where + +import Prelude + +import Control.Monad.Catch (MonadThrow) +import Data.Conduit (ConduitT, awaitForever, mergeSource, yield, (.|)) +import qualified Data.Conduit.List as CL +import Data.Foldable (traverse_) +import Data.Text (Text, pack) +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.XML.Types (Event) +import Test.Hspec.JUnit.Schema (Result(..), Suite(..), Suites(..), TestCase(..)) +import Text.Printf +import Text.XML.Stream.Render (attr, content, tag) + +renderJUnit :: MonadThrow m => ConduitT Suites Event m () +renderJUnit = awaitForever $ \Suites {..} -> + tag "testsuites" (attr "name" suitesName) + $ CL.sourceList suitesSuites + .| mergeSource idStream + .| suite + where idStream = CL.iterate (+ 1) 0 + +suite :: MonadThrow m => ConduitT (Int, Suite) Event m () +suite = awaitForever $ \(i, theSuite@Suite {..}) -> + tag "testsuite" (attributes i theSuite) $ do + tag "properties" mempty mempty + CL.sourceList suiteCases .| do + awaitForever $ \x -> yield x .| testCase + 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 $ iso8601Show 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 ] + ) + +tshow :: Show a => a -> Text +tshow = pack . show + +testCase :: MonadThrow m => ConduitT TestCase Event m () +testCase = awaitForever $ \(TestCase className name duration mResult) -> + tag "testcase" (attributes className name duration) + $ traverse_ yield mResult + .| result + where + attributes className name duration = + attr "name" name <> attr "classname" className <> attr + "time" + (roundToStr duration) + +result :: MonadThrow m => ConduitT Result Event m () +result = awaitForever go + where + go (Failure fType contents) = + tag "failure" (attr "type" fType) $ content contents + go (Skipped contents) = tag "skipped" mempty $ content contents + +sumDurations :: [TestCase] -> Double +sumDurations cases = sum $ testCaseDuration <$> cases + +roundToStr :: (PrintfArg a) => a -> Text +roundToStr = pack . printf "%0.9f" diff --git a/library/Test/Hspec/JUnit/Schema.hs b/library/Test/Hspec/JUnit/Schema.hs new file mode 100644 --- /dev/null +++ b/library/Test/Hspec/JUnit/Schema.hs @@ -0,0 +1,35 @@ +module Test.Hspec.JUnit.Schema + ( Suites(..) + , Suite(..) + , TestCase(..) + , Result(..) + ) where + +import Prelude + +import Data.Text (Text) +import Data.Time (UTCTime) + +data Suites = Suites + { suitesName :: Text + , suitesSuites :: [Suite] + } + deriving stock Show + +data Suite = Suite + { suiteName :: Text + , suiteTimestamp :: UTCTime + , suiteCases :: [TestCase] + } + deriving stock Show + +data TestCase = TestCase + { testCaseClassName :: Text + , testCaseName :: Text + , testCaseDuration :: Double + , testCaseResult :: Maybe Result + } + deriving stock Show + +data Result = Failure Text Text | Skipped Text + deriving stock Show diff --git a/tests/ExampleSpec.hs b/tests/ExampleSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleSpec.hs @@ -0,0 +1,26 @@ +-- | Example used by golden testing of XML reports +-- +-- The path name and line numbers of this file are part of the golden report +-- being tested with. So if this file changes, they will need to be regenerated. +-- +module ExampleSpec (spec) where + +import Prelude + +import Test.Hspec + +spec :: Spec +spec = do + describe "Some section" $ do + it "has an expectation" $ do + True `shouldBe` True + it "has a failure" $ do + True `shouldBe` False + + context "A grouped context" $ do + it "happens in a group" $ do + True `shouldBe` True + it "also happens in a group" $ do + True `shouldBe` True + it "gets skipped" $ do + pendingWith "some reason" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -6,43 +6,50 @@ import Prelude import Control.Monad (void) -import Test.HSpec.JUnit (junitFormat) +import qualified Data.Map.Strict as Map +import qualified ExampleSpec +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) import Test.Hspec +import Test.Hspec.JUnit import Test.Hspec.Runner +import qualified Text.XML as XML main :: IO () -main = do - summary <- flip runSpec defaultConfig $ do - describe "XML output" $ do - it "matches golen file" $ do - pendingWith - "Need to normalize time and timestamp values to match golden" - makeJunitResults - - golden <- readFile "tests/golden.xml" - test <- readFile ".temp/test.xml" - - test `shouldBe` golden - - evaluateSummary summary +main = hspec $ do + describe "XML output" $ do + it "matches golden file" $ do + withJUNitReport ExampleSpec.spec $ \doc -> do + golden <- XML.readFile XML.def "tests/golden.xml" + removeTimeAttributes doc `shouldBe` removeTimeAttributes golden -makeJunitResults :: IO () -makeJunitResults = void $ flip runSpec config $ do - describe "Some section" $ do - it "has an expectation" $ do - True `shouldBe` True - it "has a failure" $ do - True `shouldBe` False +withJUNitReport :: Spec -> (XML.Document -> IO ()) -> IO () +withJUNitReport spec f = withSystemTempDirectory "" $ \tmp -> do + let + path = tmp "test.xml" + junitConfig = + setJUnitConfigOutputDirectory tmp + $ setJUnitConfigOutputName "test.xml" + $ defaultJUnitConfig "hspec-junit-format" + hspecConfig = configWithJUnit junitConfig defaultConfig + void $ runSpec spec hspecConfig + f =<< XML.readFile XML.def path - context "A grouped context" $ do - it "happens in a group" $ do - True `shouldBe` True - it "also happens in a group" $ do - True `shouldBe` True - it "gets skipped" $ do - pendingWith "some reason" +-- | Remove volatile attributes so they don't invalidate comparison +removeTimeAttributes :: XML.Document -> XML.Document +removeTimeAttributes = + removeAttributesByName "time" . removeAttributesByName "timestamp" -config :: Config -config = defaultConfig - { configFormat = Just $ junitFormat ".temp/test.xml" "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 + } + + onNodeElement f = \case + XML.NodeElement el -> XML.NodeElement $ f el + n -> n