Skip to content
This repository was archived by the owner on Dec 2, 2024. It is now read-only.

Commit 4497333

Browse files
UlfNorellMaximilianAlgehed
UlfNorell
and
MaximilianAlgehed
authored
Add event channel to certification function (#672)
* Add event channel to certification function * add Enum and Bounded instances to CertificationTask * add hasQuickCheckTests function * Implement incremental result messages Co-authored-by: Maximilian Algehed <m.algehed@gmail.com>
1 parent 254445c commit 4497333

File tree

1 file changed

+97
-20
lines changed
  • plutus-contract-certification/src/Plutus/Contract/Test/Certification

1 file changed

+97
-20
lines changed

‎plutus-contract-certification/src/Plutus/Contract/Test/Certification/Run.hs‎

Lines changed: 97 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -30,11 +30,15 @@ module Plutus.Contract.Test.Certification.Run
3030
, certRes_DLTests
3131
-- * and we have a function for running certification
3232
, CertificationOptions(..)
33+
, CertificationEvent(..)
34+
, CertificationTask(..)
35+
, hasQuickCheckTests
3336
, defaultCertificationOptions
3437
, certify
3538
, certifyWithOptions
3639
) where
3740

41+
import Control.Concurrent.Chan
3842
import Control.Concurrent.STM
3943
import Control.Exception
4044
import Control.Lens
@@ -51,6 +55,7 @@ import Plutus.Contract.Test.Coverage
5155
import PlutusTx.Coverage
5256
import System.Random.SplitMix
5357
import Test.QuickCheck as QC
58+
import Test.QuickCheck.Property
5459
import Test.QuickCheck.Random as QC
5560
import Test.Tasty as Tasty
5661
import Test.Tasty.Runners as Tasty
@@ -103,11 +108,33 @@ makeLenses ''CertificationReport
103108
certResJSON :: CertificationReport m -> String
104109
certResJSON = unpack . encode
105110

106-
data CertificationOptions = CertificationOptions { certOptNumTests :: Int
107-
, certOptOutput :: Bool }
111+
data CertificationEvent = QuickCheckTestEvent (Maybe Bool) -- ^ Nothing if discarded, otherwise test result
112+
| StartCertificationTask CertificationTask
113+
| FinishedTask Bool
114+
deriving (Eq, Show)
115+
116+
data CertificationTask = UnitTestsTask
117+
| StandardPropertyTask
118+
| DoubleSatisfactionTask
119+
| NoLockedFundsTask
120+
| NoLockedFundsLightTask
121+
| CrashToleranceTask
122+
| WhitelistTask
123+
| DLTestsTask
124+
deriving (Eq, Show, Enum, Bounded)
125+
126+
hasQuickCheckTests :: CertificationTask -> Bool
127+
hasQuickCheckTests t = t /= UnitTestsTask
128+
129+
data CertificationOptions = CertificationOptions { certOptNumTests :: Int
130+
, certOptOutput :: Bool
131+
, certEventChannel :: Maybe (Chan CertificationEvent)
132+
}
108133

109134
defaultCertificationOptions :: CertificationOptions
110-
defaultCertificationOptions = CertificationOptions { certOptOutput = True , certOptNumTests = 100 }
135+
defaultCertificationOptions = CertificationOptions { certOptOutput = True
136+
, certOptNumTests = 100
137+
, certEventChannel = Nothing }
111138

112139
type CertMonad = WriterT CoverageReport IO
113140

@@ -122,11 +149,20 @@ runCertMonad m = do
122149
(rep, cov) <- runWriterT m
123150
return $ rep & certRes_coverageReport %~ (<> cov)
124151

152+
addOnTestEvents :: Testable prop => CertificationOptions -> prop -> Property
153+
addOnTestEvents opts prop
154+
| Just ch <- certEventChannel opts = mapResult (addCallback ch) prop
155+
| otherwise = property prop
156+
where
157+
addCallback ch r = r { callbacks = cb : callbacks r }
158+
where cb = PostTest NotCounterexample $ \ _st res -> writeChan ch $ QuickCheckTestEvent (ok res)
159+
125160
runStandardProperty :: forall m. ContractModel m => CertificationOptions -> CoverageIndex -> CertMonad QC.Result
126161
runStandardProperty opts covIdx = liftIORep $ quickCheckWithCoverageAndResult
127162
(mkQCArgs opts)
128163
(set coverageIndex covIdx defaultCoverageOptions)
129-
$ \ covopts -> propRunActionsWithOptions
164+
$ \ covopts -> addOnTestEvents opts $
165+
propRunActionsWithOptions
130166
@m
131167
defaultCheckOptionsContractModel
132168
covopts
@@ -136,21 +172,22 @@ checkDS :: forall m. ContractModel m => CertificationOptions -> CoverageIndex ->
136172
checkDS opts covIdx = liftIORep $ quickCheckWithCoverageAndResult
137173
(mkQCArgs opts)
138174
(set coverageIndex covIdx defaultCoverageOptions)
139-
$ \ covopts -> checkDoubleSatisfactionWithOptions
175+
$ \ covopts -> addOnTestEvents opts $
176+
checkDoubleSatisfactionWithOptions
140177
@m
141178
defaultCheckOptionsContractModel
142179
covopts
143180

144181
checkNoLockedFunds :: ContractModel m => CertificationOptions -> NoLockedFundsProof m -> CertMonad QC.Result
145182
checkNoLockedFunds opts prf = lift $ quickCheckWithResult
146183
(mkQCArgs opts)
147-
$ checkNoLockedFundsProof prf
184+
$ addOnTestEvents opts $ checkNoLockedFundsProof prf
148185

149186
checkNoLockedFundsLight :: ContractModel m => CertificationOptions -> NoLockedFundsProofLight m -> CertMonad QC.Result
150187
checkNoLockedFundsLight opts prf =
151188
lift $ quickCheckWithResult
152189
(mkQCArgs opts)
153-
(checkNoLockedFundsProofLight prf)
190+
$ addOnTestEvents opts $ checkNoLockedFundsProofLight prf
154191

155192
mkQCArgs :: CertificationOptions -> Args
156193
mkQCArgs CertificationOptions{..} = stdArgs { chatty = certOptOutput , maxSuccess = certOptNumTests }
@@ -173,10 +210,12 @@ runUnitTests t = liftIORep $ do
173210
checkDerived :: forall d m c. (c m => ContractModel (d m))
174211
=> Maybe (Instance c m)
175212
-> CertificationOptions
213+
-> CertificationTask
176214
-> CoverageIndex
177215
-> CertMonad (Maybe QC.Result)
178-
checkDerived Nothing _ _ = return Nothing
179-
checkDerived (Just Instance) opts covIdx = Just <$> runStandardProperty @(d m) opts covIdx
216+
checkDerived Nothing _ _ _ = return Nothing
217+
checkDerived (Just Instance) opts task covIdx =
218+
Just <$> wrapQCTask opts task (runStandardProperty @(d m) opts covIdx)
180219

181220
checkWhitelist :: forall m. ContractModel m
182221
=> Maybe Whitelist
@@ -185,10 +224,12 @@ checkWhitelist :: forall m. ContractModel m
185224
-> CertMonad (Maybe QC.Result)
186225
checkWhitelist Nothing _ _ = return Nothing
187226
checkWhitelist (Just wl) opts covIdx = do
188-
a <- liftIORep $ quickCheckWithCoverageAndResult
227+
a <- wrapQCTask opts WhitelistTask
228+
$ liftIORep $ quickCheckWithCoverageAndResult
189229
(mkQCArgs opts)
190230
(set coverageIndex covIdx defaultCoverageOptions)
191-
$ \ covopts -> checkErrorWhitelistWithOptions @m
231+
$ \ covopts -> addOnTestEvents opts $
232+
checkErrorWhitelistWithOptions @m
192233
defaultCheckOptionsContractModel
193234
covopts wl
194235
return (Just a)
@@ -199,32 +240,68 @@ checkDLTests :: forall m. ContractModel m
199240
-> CoverageIndex
200241
-> CertMonad [(String, QC.Result)]
201242
checkDLTests tests opts covIdx =
202-
sequence [(s,) <$> liftIORep (quickCheckWithCoverageAndResult
243+
wrapTask opts DLTestsTask (Prelude.all (QC.isSuccess . snd))
244+
$ sequence [(s,) <$> liftIORep (quickCheckWithCoverageAndResult
203245
(mkQCArgs opts)
204246
(set coverageIndex covIdx defaultCoverageOptions)
205-
$ \ covopts -> forAllDL dl (propRunActionsWithOptions @m defaultCheckOptionsContractModel covopts (const $ pure True)))
206-
| (s, dl) <- tests ]
247+
$ \ covopts ->
248+
addOnTestEvents opts $
249+
forAllDL dl (propRunActionsWithOptions
250+
@m
251+
defaultCheckOptionsContractModel
252+
covopts (const $ pure True)))
253+
| (s, dl) <- tests ]
254+
255+
startTaskEvent :: CertificationOptions -> CertificationTask -> CertMonad ()
256+
startTaskEvent opts task | Just ch <- certEventChannel opts = liftIO $ writeChan ch $ StartCertificationTask task
257+
| otherwise = pure ()
258+
259+
finishTaskEvent :: CertificationOptions -> Bool -> CertMonad ()
260+
finishTaskEvent opts res | Just ch <- certEventChannel opts = liftIO $ writeChan ch $ FinishedTask res
261+
| otherwise = pure ()
207262

208263
certify :: forall m. ContractModel m => Certification m -> IO (CertificationReport m)
209264
certify = certifyWithOptions defaultCertificationOptions
210265

266+
wrapTask :: CertificationOptions
267+
-> CertificationTask
268+
-> (r -> Bool)
269+
-> CertMonad r
270+
-> CertMonad r
271+
wrapTask opts task resInterp act = do
272+
startTaskEvent opts task
273+
res <- act
274+
finishTaskEvent opts $ resInterp res
275+
return res
276+
277+
wrapQCTask :: CertificationOptions
278+
-> CertificationTask
279+
-> CertMonad QC.Result
280+
-> CertMonad QC.Result
281+
wrapQCTask opts task = wrapTask opts task QC.isSuccess
282+
211283
certifyWithOptions :: forall m. ContractModel m
212284
=> CertificationOptions
213285
-> Certification m
214286
-> IO (CertificationReport m)
215287
certifyWithOptions opts Certification{..} = runCertMonad $ do
216288
-- Unit tests
217-
unitTests <- fromMaybe [] <$> traverse runUnitTests certUnitTests
289+
unitTests <- wrapTask opts UnitTestsTask (Prelude.all Tasty.resultSuccessful)
290+
$ fromMaybe [] <$> traverse runUnitTests certUnitTests
218291
-- Standard property
219-
qcRes <- runStandardProperty @m opts certCoverageIndex
292+
qcRes <- wrapQCTask opts StandardPropertyTask
293+
$ runStandardProperty @m opts certCoverageIndex
220294
-- Double satisfaction
221-
dsRes <- checkDS @m opts certCoverageIndex
295+
dsRes <- wrapQCTask opts DoubleSatisfactionTask
296+
$ checkDS @m opts certCoverageIndex
222297
-- No locked funds
223-
noLock <- traverse (checkNoLockedFunds opts) certNoLockedFunds
298+
noLock <- traverse (wrapQCTask opts NoLockedFundsTask . checkNoLockedFunds opts)
299+
certNoLockedFunds
224300
-- No locked funds light
225-
noLockLight <- traverse (checkNoLockedFundsLight opts) certNoLockedFundsLight
301+
noLockLight <- traverse (wrapQCTask opts NoLockedFundsLightTask . checkNoLockedFundsLight opts)
302+
certNoLockedFundsLight
226303
-- Crash tolerance
227-
ctRes <- checkDerived @WithCrashTolerance certCrashTolerance opts certCoverageIndex
304+
ctRes <- checkDerived @WithCrashTolerance certCrashTolerance opts CrashToleranceTask certCoverageIndex
228305
-- Whitelist
229306
wlRes <- checkWhitelist @m certWhitelist opts certCoverageIndex
230307
-- DL tests

0 commit comments

Comments
 (0)