module Test.HSpec.JUnit
  ( junitFormat
  , runJUnitSpec
  , configWith
  ) 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)
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 Test.Hspec.Core.Format
import Test.Hspec.Core.Runner
import Test.Hspec.Core.Spec (Spec)
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 =
  Spec
spec Spec -> Config -> IO Summary
`runSpec` FilePath -> FilePath -> Config -> Config
configWith FilePath
filePath FilePath
name Config
config
  where filePath :: FilePath
filePath = 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 FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/test_results.xml"

configWith :: FilePath -> String -> Config -> Config
configWith :: FilePath -> FilePath -> Config -> Config
configWith FilePath
filePath FilePath
name 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
$ FilePath -> FilePath -> FormatConfig -> IO Format
junitFormat FilePath
filePath 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 :: FilePath -> FilePath -> FormatConfig -> IO Format
junitFormat FilePath
file FilePath
suiteName 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 (FilePath
directory, FilePath
_) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
file
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
directory

    let groups :: [(Text, [(Text, Item)])]
groups = [(Path, Item)] -> [(Text, [(Text, Item)])]
groupItems [(Path, Item)]
paths
    let
      output :: Suites
output = Suites :: Text -> [Suite] -> Suites
Schema.Suites
        { suitesName :: Text
suitesName = FilePath -> Text
T.pack FilePath
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 (Text -> Text -> Item -> TestCase
itemToTestCase 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
.| FilePath -> ConduitM ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitT ByteString o m ()
sinkFile FilePath
file

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 (([FilePath]
path, FilePath
name), b
item) =
    (Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
path, [(FilePath -> Text
T.pack FilePath
name, b
item)])

itemToTestCase :: Text -> Text -> Item -> Schema.TestCase
itemToTestCase :: Text -> Text -> Item -> TestCase
itemToTestCase Text
group Text
name Item
item = TestCase :: Text -> Text -> Double -> Maybe Result -> TestCase
Schema.TestCase
  { 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 FilePath
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 -> (FilePath -> Text) -> Maybe FilePath -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        Text
""
        FilePath -> Text
T.pack
        Maybe FilePath
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 FilePath
_ SomeException
err -> FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
err
            FailureReason
NoReason -> Text
"no reason"
            Reason FilePath
err -> FilePath -> Text
T.pack FilePath
err
            ExpectedButGot Maybe FilePath
preface FilePath
expected FilePath
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
$ FilePath -> Text
T.pack
                (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
preface
                FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (Text -> FilePath -> [FilePath]
forall a. Show a => Text -> a -> [FilePath]
foundLines Text
"expected" FilePath
expected
                  [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath -> [FilePath]
forall a. Show a => Text -> a -> [FilePath]
foundLines Text
" but got" FilePath
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
FilePath
locationFile :: Location -> FilePath
locationLine :: Location -> Int
locationColumn :: Location -> Int
locationColumn :: Int
locationLine :: Int
locationFile :: FilePath
..} ->
      [Text] -> Text
T.concat
          [ FilePath -> Text
T.pack FilePath
locationFile
          , Text
":"
          , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
locationLine
          , Text
":"
          , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
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
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Item -> FilePath
itemInfo Item
item = Text
str
    | Bool
otherwise = FilePath -> Text
T.pack (Item -> FilePath
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

unSeconds :: Seconds -> Double
unSeconds :: Seconds -> Double
unSeconds (Seconds Double
x) = Double
x

foundLines :: Show a => Text -> a -> [String]
foundLines :: Text -> a -> [FilePath]
foundLines Text
msg a
found = case [Text]
lines' of
  [] -> []
  Text
first : [Text]
rest ->
    Text -> FilePath
T.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)
      FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (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 -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
rest)
  where lines' :: [Text]
lines' = 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