module Test.Hspec.JUnit
  ( configWithJUnit
  , junitFormat

  -- * Configuration
  , module Test.Hspec.JUnit.Config
  ) 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, 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.JUnit.Config
import Test.Hspec.JUnit.Render (renderJUnit)
import qualified Test.Hspec.JUnit.Schema as Schema
import Text.XML.Stream.Render (def, renderBytes)

-- | Modify an Hspec 'Config' to use 'junitFormat'
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 }

-- | Hspec 'configFormat' that generates a JUnit report
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 :: 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 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

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