{-# LANGUAGE CPP #-}

module Test.Hspec.JUnit
  {-# DEPRECATED "Use Test.Hspec.JUnit.Formatter" #-}
  ( -- * 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
  ( Event (..)
  , FailureReason (..)
  , Format
  , FormatConfig
  , Item (..)
  , Location (..)
  , Path
  , Result (..)
  , Seconds (..)
  )
import Test.Hspec.Core.Runner (Config (..), defaultConfig, hspecWith)
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'.
--
-- 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 = Just $ junitFormat junitConfig}

-- | Modify an Hspec 'Config' to have the 'junitFormat' /available/
--
-- Adds @junit@ to the list of available options for @-f, --format@.
configWithJUnitAvailable :: JUnitConfig -> Config -> Config
configWithJUnitAvailable :: JUnitConfig -> Config -> Config
configWithJUnitAvailable JUnitConfig
junitConfig Config
config =
  Config
config
    { configAvailableFormatters =
        configAvailableFormatters config <> [("junit", junitFormat 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 a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  GroupStarted Path
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  GroupDone Path
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Progress Path
_ Progress
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ItemStarted Path
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ItemDone Path
_ Item
_ -> () -> IO ()
forall a. a -> IO a
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 =
        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 =
                      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) ()
-> ConduitT Suites Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Bool -> ConduitT Suites Event (ResourceT IO) ()
forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT Suites Event m ()
renderJUnit Bool
dropConsoleFormatting
        ConduitT Suites Event (ResourceT IO) ()
-> ConduitT Event Void (ResourceT IO) ()
-> ConduitT Suites Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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) ()
-> ConduitT ByteString Void (ResourceT IO) ()
-> ConduitT Event Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| String -> ConduitT 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
  dropConsoleFormatting :: Bool
dropConsoleFormatting = JUnitConfig -> Bool
getJUnitConfigDropConsoleFormatting 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 a b. (a -> b) -> [a] -> [b]
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 =
  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 a. Maybe a -> Maybe a -> Maybe a
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
$
                  FailureReason -> Text
reasonToText FailureReason
reason
    }
 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 :: String
locationLine :: Int
locationColumn :: Int
locationFile :: Location -> String
locationLine :: Location -> Int
locationColumn :: Location -> Int
..} ->
      [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
locationFile :: Location -> String
locationLine :: Location -> Int
locationColumn :: Location -> Int
locationFile :: String
locationLine :: Int
locationColumn :: Int
..} =
  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 :: forall a. Show a => 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

{- FOURMOLU_DISABLE -}
reasonToText :: FailureReason -> Text
reasonToText :: FailureReason -> Text
reasonToText = \case
  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
#if MIN_VERSION_hspec_core(2,11,0)
  ColorizedReason String
err -> String -> Text
pack String
err
#endif
  ExpectedButGot Maybe String
preface String
expected String
actual ->
    [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
        )
{- FOURMOLU_ENABLE -}