module Test.Hspec.JUnit
(
hspecJUnit
, hspecJUnitWith
, configWithJUnit
, configWithJUnitAvailable
, junitFormat
, 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)
hspecJUnit :: Spec -> IO ()
hspecJUnit :: Spec -> IO ()
hspecJUnit = Config -> Spec -> IO ()
hspecJUnitWith Config
defaultConfig
hspecJUnitWith :: Config -> Spec -> IO ()
hspecJUnitWith :: Config -> Spec -> IO ()
hspecJUnitWith Config
config Spec
spec = do
Bool
junitEnabled <- IO Bool
envJUnitEnabled
JUnitConfig
junitConfig <- IO JUnitConfig
envJUnitConfig
let
modify :: Config -> Config
modify = if Bool
junitEnabled then JUnitConfig -> Config -> Config
configWithJUnit JUnitConfig
junitConfig else Config -> Config
forall a. a -> a
id
base :: Config
base = JUnitConfig -> Config -> Config
configWithJUnitAvailable JUnitConfig
junitConfig Config
config
Config -> Spec -> IO ()
hspecWith (Config -> Config
modify Config
base) Spec
spec
configWithJUnit :: JUnitConfig -> Config -> Config
configWithJUnit :: JUnitConfig -> Config -> Config
configWithJUnit JUnitConfig
junitConfig Config
config =
Config
config { configFormat :: Maybe (FormatConfig -> IO Format)
configFormat = (FormatConfig -> IO Format) -> Maybe (FormatConfig -> IO Format)
forall a. a -> Maybe a
Just ((FormatConfig -> IO Format) -> Maybe (FormatConfig -> IO Format))
-> (FormatConfig -> IO Format) -> Maybe (FormatConfig -> IO Format)
forall a b. (a -> b) -> a -> b
$ JUnitConfig -> FormatConfig -> IO Format
junitFormat JUnitConfig
junitConfig }
configWithJUnitAvailable :: JUnitConfig -> Config -> Config
configWithJUnitAvailable :: JUnitConfig -> Config -> Config
configWithJUnitAvailable = String -> (FormatConfig -> IO Format) -> Config -> Config
configAddAvailableFormatter String
"junit" ((FormatConfig -> IO Format) -> Config -> Config)
-> (JUnitConfig -> FormatConfig -> IO Format)
-> JUnitConfig
-> Config
-> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JUnitConfig -> FormatConfig -> IO Format
junitFormat
junitFormat :: JUnitConfig -> FormatConfig -> IO Format
junitFormat :: JUnitConfig -> FormatConfig -> IO Format
junitFormat JUnitConfig
junitConfig FormatConfig
_config = Format -> IO Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> IO Format) -> Format -> IO Format
forall a b. (a -> b) -> a -> b
$ \case
Event
Started -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
GroupStarted Path
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
GroupDone Path
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Progress Path
_ Progress
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ItemStarted Path
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ItemDone Path
_ Item
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Done [(Path, Item)]
paths -> do
UTCTime
time <- IO UTCTime
getCurrentTime
let (String
directory, String
_) = String -> (String, String)
splitFileName String
file
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
directory
let
groups :: [(Text, [(Text, Item)])]
groups = [(Path, Item)] -> [(Text, [(Text, Item)])]
groupItems [(Path, Item)]
paths
output :: Suites
output = Suites :: Text -> [Suite] -> Suites
Schema.Suites
{ suitesName :: Text
suitesName = Text
suiteName
, suitesSuites :: [Suite]
suitesSuites = [(Text, [(Text, Item)])]
groups [(Text, [(Text, Item)])]
-> ((Text, [(Text, Item)]) -> Suite) -> [Suite]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Text
group, [(Text, Item)]
items) -> do
let
suite :: [TestCase] -> Suite
suite [TestCase]
xs = Suite :: Text -> UTCTime -> [TestCase] -> Suite
Schema.Suite
{ suiteName :: Text
suiteName = Text
group
, suiteTimestamp :: UTCTime
suiteTimestamp = UTCTime
time
, suiteCases :: [TestCase]
suiteCases = [TestCase]
xs
}
[TestCase] -> Suite
suite ([TestCase] -> Suite) -> [TestCase] -> Suite
forall a b. (a -> b) -> a -> b
$ (Text -> Item -> TestCase) -> (Text, Item) -> TestCase
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((String -> String) -> Text -> Text -> Item -> TestCase
itemToTestCase String -> String
applyPrefix Text
group) ((Text, Item) -> TestCase) -> [(Text, Item)] -> [TestCase]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Item)]
items
}
ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
(ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Suites] -> ConduitT () Suites (ResourceT IO) ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
sourceList [Suites
output]
ConduitT () Suites (ResourceT IO) ()
-> ConduitM Suites Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT Suites Event (ResourceT IO) ()
forall (m :: * -> *). MonadThrow m => ConduitT Suites Event m ()
renderJUnit
ConduitT Suites Event (ResourceT IO) ()
-> ConduitM Event Void (ResourceT IO) ()
-> ConduitM Suites Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| RenderSettings -> ConduitT Event ByteString (ResourceT IO) ()
forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
renderBytes RenderSettings
forall a. Default a => a
def
ConduitT Event ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) ()
-> ConduitM Event Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| String -> ConduitM ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadResource m =>
String -> ConduitT ByteString o m ()
sinkFile String
file
where
file :: String
file = JUnitConfig -> String
getJUnitConfigOutputFile JUnitConfig
junitConfig
suiteName :: Text
suiteName = JUnitConfig -> Text
getJUnitConfigSuiteName JUnitConfig
junitConfig
applyPrefix :: String -> String
applyPrefix = JUnitConfig -> String -> String
getJUnitPrefixSourcePath JUnitConfig
junitConfig
groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])]
groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])]
groupItems = Map Text [(Text, Item)] -> [(Text, [(Text, Item)])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text [(Text, Item)] -> [(Text, [(Text, Item)])])
-> ([(Path, Item)] -> Map Text [(Text, Item)])
-> [(Path, Item)]
-> [(Text, [(Text, Item)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, Item)] -> [(Text, Item)] -> [(Text, Item)])
-> [(Text, [(Text, Item)])] -> Map Text [(Text, Item)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(Text, Item)] -> [(Text, Item)] -> [(Text, Item)]
forall a. Semigroup a => a -> a -> a
(<>) ([(Text, [(Text, Item)])] -> Map Text [(Text, Item)])
-> ([(Path, Item)] -> [(Text, [(Text, Item)])])
-> [(Path, Item)]
-> Map Text [(Text, Item)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Path, Item) -> (Text, [(Text, Item)]))
-> [(Path, Item)] -> [(Text, [(Text, Item)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path, Item) -> (Text, [(Text, Item)])
forall b. (Path, b) -> (Text, [(Text, b)])
group
where
group :: (Path, b) -> (Text, [(Text, b)])
group (([String]
path, String
name), b
item) =
(Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
path, [(String -> Text
pack String
name, b
item)])
itemToTestCase
:: (FilePath -> FilePath) -> Text -> Text -> Item -> Schema.TestCase
itemToTestCase :: (String -> String) -> Text -> Text -> Item -> TestCase
itemToTestCase String -> String
applyPrefix Text
group Text
name Item
item = TestCase :: Maybe Location
-> Text -> Text -> Double -> Maybe Result -> TestCase
Schema.TestCase
{ testCaseLocation :: Maybe Location
testCaseLocation =
(String -> String) -> Location -> Location
toSchemaLocation String -> String
applyPrefix
(Location -> Location) -> Maybe Location -> Maybe Location
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Item -> Maybe Location
itemResultLocation Item
item Maybe Location -> Maybe Location -> Maybe Location
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Item -> Maybe Location
itemLocation Item
item)
, testCaseClassName :: Text
testCaseClassName = Text
group
, testCaseName :: Text
testCaseName = Text
name
, testCaseDuration :: Double
testCaseDuration = Seconds -> Double
unSeconds (Seconds -> Double) -> Seconds -> Double
forall a b. (a -> b) -> a -> b
$ Item -> Seconds
itemDuration Item
item
, testCaseResult :: Maybe Result
testCaseResult = case Item -> Result
itemResult Item
item of
Result
Success -> Maybe Result
forall a. Maybe a
Nothing
Pending Maybe Location
mLocation Maybe String
mMessage ->
Result -> Maybe Result
forall a. a -> Maybe a
Just (Result -> Maybe Result) -> Result -> Maybe Result
forall a b. (a -> b) -> a -> b
$ Text -> Result
Schema.Skipped (Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> Text -> Text
prefixLocation Maybe Location
mLocation (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
prefixInfo (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Text
""
String -> Text
pack
Maybe String
mMessage
Failure Maybe Location
mLocation FailureReason
reason ->
Result -> Maybe Result
forall a. a -> Maybe a
Just
(Result -> Maybe Result) -> Result -> Maybe Result
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Result
Schema.Failure Text
"error"
(Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> Text -> Text
prefixLocation Maybe Location
mLocation
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
prefixInfo
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ case FailureReason
reason of
Error Maybe String
_ SomeException
err -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
err
FailureReason
NoReason -> Text
"no reason"
Reason String
err -> String -> Text
pack String
err
ExpectedButGot Maybe String
preface String
expected String
actual ->
Text -> Text
prefixInfo
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack
(String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
preface
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Text -> String -> [String]
forall a. Show a => Text -> a -> [String]
foundLines Text
"expected" String
expected
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Text -> String -> [String]
forall a. Show a => Text -> a -> [String]
foundLines Text
" but got" String
actual
)
}
where
prefixLocation :: Maybe Location -> Text -> Text
prefixLocation Maybe Location
mLocation Text
str = case Maybe Location
mLocation of
Maybe Location
Nothing -> Text
str
Just Location {Int
String
locationFile :: Location -> String
locationLine :: Location -> Int
locationColumn :: Location -> Int
locationColumn :: Int
locationLine :: Int
locationFile :: String
..} ->
[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
applyPrefix String
locationFile
, Text
":"
, String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
locationLine
, Text
":"
, String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
locationColumn
, Text
"\n"
]
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str
prefixInfo :: Text -> Text
prefixInfo Text
str
| Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Item -> String
itemInfo Item
item = Text
str
| Bool
otherwise = String -> Text
pack (Item -> String
itemInfo Item
item) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str
itemResultLocation :: Item -> Maybe Location
itemResultLocation :: Item -> Maybe Location
itemResultLocation Item
item = case Item -> Result
itemResult Item
item of
Result
Success -> Maybe Location
forall a. Maybe a
Nothing
Pending Maybe Location
mLocation Maybe String
_ -> Maybe Location
mLocation
Failure Maybe Location
mLocation FailureReason
_ -> Maybe Location
mLocation
toSchemaLocation :: (FilePath -> FilePath) -> Location -> Schema.Location
toSchemaLocation :: (String -> String) -> Location -> Location
toSchemaLocation String -> String
applyPrefix Location {Int
String
locationColumn :: Int
locationLine :: Int
locationFile :: String
locationFile :: Location -> String
locationLine :: Location -> Int
locationColumn :: Location -> Int
..} = Location :: String -> Natural -> Location
Schema.Location
{ locationFile :: String
Schema.locationFile = String -> String
applyPrefix String
locationFile
, locationLine :: Natural
Schema.locationLine = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
locationLine
}
unSeconds :: Seconds -> Double
unSeconds :: Seconds -> Double
unSeconds (Seconds Double
x) = Double
x
foundLines :: Show a => Text -> a -> [String]
foundLines :: Text -> a -> [String]
foundLines Text
msg a
found = case [Text]
lines' of
[] -> []
Text
first : [Text]
rest ->
Text -> String
unpack (Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
first) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Text -> String
unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.replicate Int
9 Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
rest)
where lines' :: [Text]
lines' = Text -> [Text]
T.lines (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
found