module Test.HSpec.JUnit
  ( runJUnitSpec
  , configWith
  ) where

import Prelude

import Control.Monad.Trans.Resource (runResourceT)
import Data.Conduit (runConduit, (.|))
import Data.Conduit.Combinators (sinkFile)
import Data.Foldable (traverse_)
import Data.Text (Text)
import qualified Data.Text as T
import System.Directory (createDirectoryIfMissing)
import System.IO.Temp (emptySystemTempFile)
import Test.HSpec.JUnit.Parse (denormalize, parseJUnit)
import Test.HSpec.JUnit.Render (renderJUnit)
import Test.Hspec (Spec)
import Test.Hspec.Formatters
  (FailureReason(..), FormatM, Formatter(..), writeLine)
import Test.Hspec.Runner (Config(..), Summary, runSpec)
import Text.XML.Stream.Parse (parseFile)
import Text.XML.Stream.Render (def, renderBytes)

runJUnitSpec :: Spec -> (FilePath, String) -> Config -> IO Summary
runJUnitSpec :: Spec -> (FilePath, FilePath) -> Config -> IO Summary
runJUnitSpec Spec
spec (FilePath
path, FilePath
name) Config
config = do
  FilePath
tempFile <- FilePath -> IO FilePath
emptySystemTempFile (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"hspec-junit-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
name
  Summary
summary <- Spec
spec Spec -> Config -> IO Summary
`runSpec` FilePath -> FilePath -> Config -> Config
configWith FilePath
tempFile FilePath
name Config
config
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dirPath
  ResourceT IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
    (ResourceT IO () -> IO ())
-> (ConduitT () Void (ResourceT IO) () -> ResourceT IO ())
-> ConduitT () Void (ResourceT IO) ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () Void (ResourceT IO) () -> ResourceT IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
    (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ ParseSettings -> FilePath -> ConduitT () Event (ResourceT IO) ()
forall (m :: * -> *) i.
MonadResource m =>
ParseSettings -> FilePath -> ConduitT i Event m ()
parseFile ParseSettings
forall a. Default a => a
def FilePath
tempFile
    ConduitT () Event (ResourceT IO) ()
-> ConduitM Event 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 Event Suites (ResourceT IO) ()
forall (m :: * -> *). MonadThrow m => ConduitT Event Suites m ()
parseJUnit
    -- HSpec's formatter cannot correctly output JUnit, so we must denormalize
    -- nested <testsuite /> elements.
    ConduitT Event Suites (ResourceT IO) ()
-> ConduitM Suites 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
.| ConduitT Suites Suites (ResourceT IO) ()
forall (m :: * -> *). MonadThrow m => ConduitT Suites Suites m ()
denormalize
    ConduitT Suites Suites (ResourceT IO) ()
-> ConduitM Suites 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
.| 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
.| FilePath -> ConduitM ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitT ByteString o m ()
sinkFile (FilePath
dirPath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/test_results.xml")
  Summary -> IO Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure Summary
summary
  where dirPath :: FilePath
dirPath = FilePath
path FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
name

configWith :: FilePath -> String -> Config -> Config
configWith :: FilePath -> FilePath -> Config -> Config
configWith FilePath
filePath FilePath
name Config
config = Config
config
  { configFormatter :: Maybe Formatter
configFormatter = Formatter -> Maybe Formatter
forall a. a -> Maybe a
Just (Formatter -> Maybe Formatter) -> Formatter -> Maybe Formatter
forall a b. (a -> b) -> a -> b
$ FilePath -> Formatter
junitFormatter FilePath
name
  , configOutputFile :: Either Handle FilePath
configOutputFile = FilePath -> Either Handle FilePath
forall a b. b -> Either a b
Right FilePath
filePath
  }

junitFormatter :: String -> Formatter
junitFormatter :: FilePath -> Formatter
junitFormatter FilePath
suiteName = Formatter :: FormatM ()
-> ([FilePath] -> FilePath -> FormatM ())
-> FormatM ()
-> (Path -> Progress -> FormatM ())
-> (Path -> FilePath -> FormatM ())
-> (Path -> FilePath -> FailureReason -> FormatM ())
-> (Path -> FilePath -> Maybe FilePath -> FormatM ())
-> FormatM ()
-> FormatM ()
-> Formatter
Formatter
  { headerFormatter :: FormatM ()
headerFormatter = do
    FilePath -> FormatM ()
writeLine FilePath
"<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
    FilePath -> FormatM ()
writeLine (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ FilePath
"<testsuites name=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
suiteName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
">"
  -- TODO needs: package, id, timestamp, hostname, tests, failures, errors, time
  , exampleGroupStarted :: [FilePath] -> FilePath -> FormatM ()
exampleGroupStarted = \[FilePath]
_paths FilePath
name ->
    FilePath -> FormatM ()
writeLine (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ FilePath
"<testsuite name=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
forall a. Show a => a -> FilePath
show (Text -> Text
fixBrackets (FilePath -> Text
T.pack FilePath
name)) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
">"
  , exampleGroupDone :: FormatM ()
exampleGroupDone = FilePath -> FormatM ()
writeLine FilePath
"</testsuite>"
  , exampleProgress :: Path -> Progress -> FormatM ()
exampleProgress = \Path
_ Progress
_ -> () -> FormatM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , exampleSucceeded :: Path -> FilePath -> FormatM ()
exampleSucceeded = \Path
path FilePath
_info -> do
    Path -> FormatM ()
testCaseOpen Path
path
    FormatM ()
testCaseClose
  , exampleFailed :: Path -> FilePath -> FailureReason -> FormatM ()
exampleFailed = \Path
path FilePath
info FailureReason
reason -> do
    Path -> FormatM ()
testCaseOpen Path
path
    FilePath -> FormatM ()
writeLine FilePath
"<failure type=\"error\">"
    (FilePath -> FormatM ()) -> [FilePath] -> FormatM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FilePath -> FormatM ()
writeLine (FilePath -> FormatM ())
-> (FilePath -> FilePath) -> FilePath -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
fixReason) ([FilePath] -> FormatM ()) -> [FilePath] -> FormatM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
info
    case FailureReason
reason of
      Error Maybe FilePath
_ SomeException
err -> FilePath -> FormatM ()
writeLine (FilePath -> FormatM ())
-> (FilePath -> FilePath) -> FilePath -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
fixReason (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
err
      FailureReason
NoReason -> FilePath -> FormatM ()
writeLine FilePath
"no reason"
      Reason FilePath
err -> (FilePath -> FormatM ()) -> [FilePath] -> FormatM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FilePath -> FormatM ()
writeLine (FilePath -> FormatM ())
-> (FilePath -> FilePath) -> FilePath -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
fixReason) ([FilePath] -> FormatM ()) -> [FilePath] -> FormatM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
err
      ExpectedButGot Maybe FilePath
preface FilePath
expected FilePath
actual -> do
        (FilePath -> FormatM ()) -> Maybe FilePath -> FormatM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> FormatM ()
writeLine Maybe FilePath
preface
        Text -> FilePath -> FormatM ()
forall a. Show a => Text -> a -> FormatM ()
writeFound Text
"expected" FilePath
expected
        Text -> FilePath -> FormatM ()
forall a. Show a => Text -> a -> FormatM ()
writeFound Text
" but got" FilePath
actual
    FilePath -> FormatM ()
writeLine FilePath
"</failure>"
    FormatM ()
testCaseClose
  , examplePending :: Path -> FilePath -> Maybe FilePath -> FormatM ()
examplePending = \Path
path FilePath
info Maybe FilePath
reason -> do
    Path -> FormatM ()
testCaseOpen Path
path
    FilePath -> FormatM ()
writeLine FilePath
"<skipped>"
    (FilePath -> FormatM ()) -> [FilePath] -> FormatM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FilePath -> FormatM ()
writeLine (FilePath -> FormatM ())
-> (FilePath -> FilePath) -> FilePath -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
fixReason) ([FilePath] -> FormatM ()) -> [FilePath] -> FormatM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
info
    FilePath -> FormatM ()
writeLine (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"No reason given" FilePath -> FilePath
fixReason Maybe FilePath
reason
    FilePath -> FormatM ()
writeLine FilePath
"</skipped>"
    FormatM ()
testCaseClose
  , failedFormatter :: FormatM ()
failedFormatter = () -> FormatM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , footerFormatter :: FormatM ()
footerFormatter = FilePath -> FormatM ()
writeLine FilePath
"</testsuites>"
  }

testCaseOpen :: ([String], String) -> FormatM ()
testCaseOpen :: Path -> FormatM ()
testCaseOpen ([FilePath]
parents, FilePath
name) = FilePath -> FormatM ()
writeLine (FilePath -> FormatM ()) -> FilePath -> FormatM ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat
  [ FilePath
"<testcase name="
  , Text -> FilePath
forall a. Show a => a -> FilePath
show (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
fixBrackets (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
name
  , FilePath
" classname="
  , Text -> FilePath
forall a. Show a => a -> FilePath
show (Text -> FilePath) -> ([Text] -> Text) -> [Text] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
fixBrackets (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> FilePath) -> [Text] -> FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
T.pack [FilePath]
parents
  , FilePath
">"
  ]

testCaseClose :: FormatM ()
testCaseClose :: FormatM ()
testCaseClose = FilePath -> FormatM ()
writeLine FilePath
"</testcase>"

fixBrackets :: Text -> Text
fixBrackets :: Text -> Text
fixBrackets =
  Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"&quot;"
    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"<" Text
"&lt;"
    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
">" Text
"&gt;"
    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"&" Text
"&amp;"

fixReason :: String -> String
fixReason :: FilePath -> FilePath
fixReason = Text -> FilePath
T.unpack (Text -> FilePath) -> (FilePath -> Text) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
fixBrackets (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack

writeFound :: Show a => Text -> a -> FormatM ()
writeFound :: Text -> a -> FormatM ()
writeFound Text
msg a
found = case [Text]
lines' of
  [] -> () -> FormatM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Text
first : [Text]
rest -> do
    FilePath -> FormatM ()
writeLine (FilePath -> FormatM ())
-> (Text -> FilePath) -> Text -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FormatM ()) -> Text -> FormatM ()
forall a b. (a -> b) -> a -> b
$ 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
    (Text -> FormatM ()) -> [Text] -> FormatM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FilePath -> FormatM ()
writeLine (FilePath -> FormatM ())
-> (Text -> FilePath) -> Text -> FormatM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
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]
rest
  where lines' :: [Text]
lines' = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
fixBrackets ([Text] -> [Text]) -> (FilePath -> [Text]) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [Text]) -> (FilePath -> Text) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> [Text]) -> FilePath -> [Text]
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. Show a => a -> FilePath
show a
found