-
Notifications
You must be signed in to change notification settings - Fork 14
/
AntXML.hs
182 lines (151 loc) · 7.14 KB
/
AntXML.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-- | Run a 'Tasty.TestTree' and produce an XML file summarising the test results
-- in the same schema that would be produced by Apache Ant's JUnit test runner.
-- This schema can be intepreted by the Jenkins continuous integration server,
-- amongst other tools.
module Test.Tasty.Runners.AntXML (antXMLRunner, AntXMLPath(..) ) where
import Numeric (showFFloat)
import Control.Applicative
import Control.Arrow (first)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..), Endo(..), Sum(..))
import Data.Proxy (Proxy(..))
import Data.Tagged (Tagged(..))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import System.Directory (createDirectoryIfMissing, canonicalizePath)
import System.FilePath (takeDirectory)
import qualified Control.Concurrent.STM as STM
import qualified Control.Monad.State as State
import qualified Control.Monad.Reader as Reader
import qualified Data.Functor.Compose as Functor
import qualified Data.IntMap as IntMap
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.Providers as Tasty
import qualified Test.Tasty.Options as Tasty
import qualified Test.Tasty.Runners as Tasty
import qualified Text.XML.Light as XML
--------------------------------------------------------------------------------
newtype AntXMLPath = AntXMLPath FilePath
deriving (Typeable)
instance Tasty.IsOption (Maybe AntXMLPath) where
defaultValue = Nothing
parseValue = Just . Just . AntXMLPath
optionName = Tagged "xml"
optionHelp = Tagged "A file path to store the test results in Ant-compatible XML"
--------------------------------------------------------------------------------
data Summary = Summary { summaryFailures :: Sum Int
, summaryErrors :: Sum Int
, summarySuccesses :: Sum Int
, xmlRenderer :: Endo XML.Element
} deriving (Generic)
instance Monoid Summary where
mempty = memptydefault
mappend = mappenddefault
--------------------------------------------------------------------------------
{-|
To run tests using this ingredient, use 'Tasty.defaultMainWithIngredients',
passing 'antXMLRunner' as one possible ingredient. This ingredient will run
tests if you pass the @--xml@ command line option. For example,
@--xml=junit.xml@ will run all the tests and generate @junit.xml@ as output.
-}
antXMLRunner :: Tasty.Ingredient
antXMLRunner = Tasty.TestReporter optionDescription runner
where
optionDescription = [ Tasty.Option (Proxy :: Proxy (Maybe AntXMLPath)) ]
runner options testTree = do
AntXMLPath path <- Tasty.lookupOption options
return $ \statusMap ->
let
timeDigits = 3
showTime time = showFFloat (Just timeDigits) time ""
runTest :: (Tasty.IsTest t)
=> Tasty.OptionSet
-> Tasty.TestName
-> t
-> Tasty.Traversal (Functor.Compose (Reader.ReaderT [String] (State.StateT IntMap.Key IO)) (Const Summary))
runTest _ testName _ = Tasty.Traversal $ Functor.Compose $ do
i <- State.get
groupNames <- Reader.ask
summary <- liftIO $ STM.atomically $ do
status <- STM.readTVar $
fromMaybe (error "Attempted to lookup test by index outside bounds") $
IntMap.lookup i statusMap
let testCaseAttributes time = map (uncurry XML.Attr . first XML.unqual)
[ ("name", testName)
, ("time", showTime time)
, ("classname", unwords groupNames)
]
mkSummary contents =
mempty { xmlRenderer = Endo
(`appendChild` XML.node (XML.unqual "testcase") contents)
}
mkSuccess time = (mkSummary (testCaseAttributes time)) { summarySuccesses = Sum 1 }
mkFailure time reason =
mkSummary ( testCaseAttributes time
, XML.node (XML.unqual "failure") reason
)
case status of
-- If the test is done, generate XML for it
Tasty.Done result
| Tasty.resultSuccessful result -> pure (mkSuccess (Tasty.resultTime result))
| otherwise ->
case resultException result of
Just e -> pure $ (mkFailure (Tasty.resultTime result) (show e)) { summaryErrors = Sum 1 }
Nothing -> pure $
if resultTimedOut result
then (mkFailure (Tasty.resultTime result) "TimeOut") { summaryErrors = Sum 1 }
else (mkFailure (Tasty.resultTime result) (Tasty.resultDescription result))
{ summaryFailures = Sum 1 }
-- Otherwise the test has either not been started or is currently
-- executing
_ -> STM.retry
Const summary <$ State.modify (+ 1)
runGroup groupName children = Tasty.Traversal $ Functor.Compose $ do
Const soFar <- Reader.withReaderT (++ [groupName]) $ Functor.getCompose $ Tasty.getTraversal children
let grouped = appEndo (xmlRenderer soFar) $
XML.node (XML.unqual "testsuite") $
XML.Attr (XML.unqual "name") groupName
pure $ Const
soFar { xmlRenderer = Endo (`appendChild` grouped)
}
in do
(Const summary, tests) <-
flip State.runStateT 0 $ flip Reader.runReaderT [] $ Functor.getCompose $ Tasty.getTraversal $
Tasty.foldTestTree
Tasty.trivialFold { Tasty.foldSingle = runTest, Tasty.foldGroup = runGroup }
options
testTree
return $ \elapsedTime -> do
createPathDirIfMissing path
writeFile path $
XML.showTopElement $
appEndo (xmlRenderer summary) $
XML.node
(XML.unqual "testsuites")
[ XML.Attr (XML.unqual "errors")
(show . getSum . summaryErrors $ summary)
, XML.Attr (XML.unqual "failures")
(show . getSum . summaryFailures $ summary)
, XML.Attr (XML.unqual "tests") (show tests)
, XML.Attr (XML.unqual "time") (showTime elapsedTime)
]
return (getSum ((summaryFailures `mappend` summaryErrors) summary) == 0)
appendChild parent child =
parent { XML.elContent = XML.elContent parent ++ [ XML.Elem child ] }
resultException r =
case Tasty.resultOutcome r of
Tasty.Failure (Tasty.TestThrewException e) -> Just e
_ -> Nothing
resultTimedOut r =
case Tasty.resultOutcome r of
Tasty.Failure (Tasty.TestTimedOut _) -> True
_ -> False
createPathDirIfMissing path = fmap takeDirectory (canonicalizePath path)
>>= createDirectoryIfMissing True