{-# 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 -}