module Test.Hspec.JUnit
  (
  -- * 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
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)

-- | 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'.
--
-- (If using hspec >= 2.9, 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 :: Spec -> IO ()
hspecJUnit = Config -> Spec -> IO ()
hspecJUnitWith Config
defaultConfig

-- | 'hspecJUnit' but built on a non-default 'Config'
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

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

-- | Modify an Hspec 'Config' to have the 'junitFormat' /available/
--
-- Adds @junit@ to the list of available options for @-f, --format@.
--
-- __NOTE__: This only works with hspec >= 2.9, otherwise it is a no-op.
--
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

-- | 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 :: 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