module Test.Hspec.JUnit
(
-- * 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
import Test.Hspec.Core.Runner
import Test.Hspec.Core.Runner.Ext
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'.
--
-- (If using hspec >= 2.9, 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@.
--
-- __NOTE__: This only works with hspec >= 2.9, otherwise it is a no-op.
--
configWithJUnitAvailable :: JUnitConfig -> Config -> Config
configWithJUnitAvailable = configAddAvailableFormatter "junit" . junitFormat
-- | 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
.| renderBytes def
.| sinkFile file
where
file = getJUnitConfigOutputFile junitConfig
suiteName = getJUnitConfigSuiteName junitConfig
applyPrefix = getJUnitPrefixSourcePath 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
$ 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 $ 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