Model-based Testing With Quickcheck-Dynamic

hydra-node/json-schemas/api.yaml

@@ -534,15 +534,18 @@ components:
     CommandFailed:
       title: CommandFailed
       description: |
-        Emitted by the server when a well-formed client input was not processable. For example, if trying to close a non opened head or, when trying to commit after having already comitted.
+        Emitted by the server when a well-formed client input was not processable. For example, if trying to close a non opened head or, when trying to commit after having already committed.
       payload:
         type: object
         required:
         - tag
+        - clientInput
         properties:
           tag:
             type: string
             enum: ["CommandFailed"]
+          clientInput:
+            $ref: "#/components/schemas/ClientInput"
 
   ########
   #

hydra-node/src/Hydra/Crypto.hs

@@ -56,10 +56,6 @@ type SignAlg = Ed25519DSIGN
 newtype SigningKey = HydraSigningKey (SignKeyDSIGN SignAlg)
   deriving (Eq, Show)
 
-instance Ord SigningKey where
-  k `compare` k' =
-    serialiseSigningKeyToRawBytes k `compare` serialiseSigningKeyToRawBytes k'
-
 instance Arbitrary SigningKey where
   arbitrary = generateSigningKey <$> arbitrary
 

hydra-node/src/Hydra/ServerOutput.hs

@@ -60,7 +60,7 @@ instance IsTx tx => Arbitrary (ServerOutput tx) where
     ReadyToFanout -> []
     HeadIsFinalized u -> HeadIsFinalized <$> shrink u
     HeadIsAborted u -> HeadIsAborted <$> shrink u
-    CommandFailed _ -> []
+    CommandFailed i -> CommandFailed <$> shrink i
     TxSeen tx -> TxSeen <$> shrink tx
     TxValid tx -> TxValid <$> shrink tx
     TxInvalid u tx err -> TxInvalid <$> shrink u <*> shrink tx <*> shrink err

hydra-node/test/Hydra/Model.hs

@@ -393,17 +393,17 @@ instance
       Input.NewTx{Input.transaction = tx} ->
         performNewTx st party tx
       Input.Init{Input.contestationPeriod = p} ->
-        party `performs` Input.Init{Input.contestationPeriod = p}
+        party `sendsInput` Input.Init{Input.contestationPeriod = p}
       Input.Abort -> do
-        party `performs` Input.Abort
+        party `sendsInput` Input.Abort
       Input.GetUTxO -> do
-        party `performs` Input.GetUTxO
+        party `sendsInput` Input.GetUTxO
       Input.Close -> do
-        party `performs` Input.Close
+        party `sendsInput` Input.Close
       Input.Contest -> do
-        party `performs` Input.Contest
+        party `sendsInput` Input.Contest
       Input.Fanout -> do
-        party `performs` Input.Fanout
+        party `sendsInput` Input.Fanout
 
   monitoring (s, s') _action _lookup _return =
     case (hydraState s, hydraState s') of
@@ -418,8 +418,8 @@ deriving instance Eq (Action (WorldState m) a)
 
 --
 
-performs :: Monad m => Party -> ClientInput Tx -> StateT (Nodes m) m ()
-performs party command = do
+sendsInput :: Monad m => Party -> ClientInput Tx -> StateT (Nodes m) m ()
+sendsInput party command = do
   nodes <- gets nodes
   case Map.lookup party nodes of
     Nothing -> error $ "unexpected party " <> Hydra.Prelude.show party
@@ -468,7 +468,7 @@ performCommit party utxo = do
               , let vk = getVerificationKey sk
               , let txOut = TxOut (mkVkAddress testNetworkId vk) val TxOutDatumNone
               ]
-      party `performs` Input.Commit{Input.utxo = realUtxo}
+      party `sendsInput` Input.Commit{Input.utxo = realUtxo}
 
 performNewTx ::
   (MonadThrow m, MonadAsync m, MonadTimer m) =>
@@ -490,7 +490,7 @@ performNewTx st party tx = do
           Just{} -> pure ()
   waitForOpen
 
-  party `performs` Input.GetUTxO
+  party `sendsInput` Input.GetUTxO
 
   let matchPayment p@(_, txOut) =
         isOwned (from tx) p && value tx == txOutValue txOut
@@ -510,11 +510,11 @@ performNewTx st party tx = do
           lift (threadDelay 1 >> waitForNext (nodes ! party)) >>= \case
             GetUTxOResponse u
               | u == mempty -> do
-                party `performs` Input.GetUTxO
+                party `sendsInput` Input.GetUTxO
                 waitForUTxO u (n -1)
               | otherwise -> case find matchPayment (UTxO.pairs u) of
                 Nothing -> do
-                  party `performs` Input.GetUTxO
+                  party `sendsInput` Input.GetUTxO
                   waitForUTxO u (n -1)
                 Just p -> pure p
             _ ->
@@ -528,7 +528,7 @@ performNewTx st party tx = do
           id
           (mkSimpleTx (i, o) (recipient, value tx) (from tx))
 
-  party `performs` Input.NewTx realTx
+  party `sendsInput` Input.NewTx realTx
   lift $
     waitUntilMatch [nodes ! party] $ \case
       SnapshotConfirmed{Output.snapshot = snapshot} ->

hydra-node/test/Test/Util.hs

@@ -17,7 +17,6 @@ import Control.Monad.IOSim (
 import Control.Tracer (Tracer (Tracer))
 import qualified Data.Aeson as Aeson
 import Data.List (isInfixOf)
-import Hydra.Ledger (IsTx)
 import Hydra.Ledger.Simple (SimpleTx)
 import Hydra.Node (HydraNodeLog)
 import Test.HUnit.Lang (FailureReason (ExpectedButGot), HUnitFailure (HUnitFailure))
@@ -38,14 +37,13 @@ shouldRunInSim action =
       throwIO ex
  where
   tr = runSimTrace action
-  dumpTrace = say (toString $ printTrace (Proxy :: Proxy SimpleTx) tr)
+  dumpTrace = say (toString $ printTrace (Proxy :: Proxy (HydraNodeLog SimpleTx)) tr)
 
 -- | Utility function to dump logs given a `SimTrace`.
--- TODO(SN): take a proxy instead of hard-coding HydraNodeLog
-printTrace :: forall tx a. IsTx tx => Proxy tx -> SimTrace a -> Text
+printTrace :: forall log a. (Typeable log, ToJSON log) => Proxy log -> SimTrace a -> Text
 printTrace _ tr =
   unlines . map (decodeUtf8 . Aeson.encode) $
-    selectTraceEventsDynamic' @_ @(HydraNodeLog tx) tr
+    selectTraceEventsDynamic' @_ @log tr
 
 -- | Lifted variant of Hspec's 'shouldBe'.
 shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()