Merge pull request #75 from mlabs-haskell/uhbif19/quickcheck-dynamic-…

…support

Quickcheck dynamic support

.hlint.yaml

@@ -2,11 +2,17 @@
 - group: {name: generalise, enabled: true}
 - functions:
   - {name: undefined, within: []}
+# Do not prohibit using more monomorphic functions
 - ignore: {name: Use pure}
+- ignore: {name: Use fmap}
+- ignore: {name: Use traverse_}
+- ignore: {name: "Use <>"}
+# Do not enforce less explicit expressions
+# and util functions consisting of single line of code
+- ignore: {name: Use isNothing}
 - ignore: {name: Use print}
 - ignore: {name: Use null}
 - ignore: {name: Use notElem}
 - ignore: {name: Use unless}
-- ignore: {name: Use fmap}
-- ignore: {name: Use traverse_}
 - ignore: {name: "Use asks"}
+- ignore: {name: "Eta reduce"}

cem-script.cabal

@@ -170,6 +170,7 @@ library
     Cardano.CEM.OffChain
     Cardano.CEM.OnChain
     Cardano.CEM.Stages
+    Cardano.CEM.Testing.StateMachine
 
   other-modules:   Cardano.CEM.Monads.L1Commons
   build-depends:
@@ -178,6 +179,8 @@ library
     , clb
     , dependent-map
     , ouroboros-consensus
+    , QuickCheck
+    , quickcheck-dynamic
     , singletons-th
 
 test-suite cem-sdk-test
@@ -201,6 +204,7 @@ test-suite cem-sdk-test
   hs-source-dirs: test/
   other-modules:
     Auction
+    Dynamic
     OffChain
     TestNFT
     Utils

src-lib/data-spine/Data/Spine.hs

@@ -25,13 +25,13 @@ class
   type Spine sop
   getSpine :: sop -> Spine sop
 
--- instance (SingI sop1, SingI sop2) => SingI (sop1, sop2) where
-
 instance (HasSpine sop1, HasSpine sop2) => HasSpine (sop1, sop2) where
   type Spine (sop1, sop2) = (Spine sop1, Spine sop2)
   getSpine (d1, d2) = (getSpine d1, getSpine d2)
 
--- TODO: mkOfSpine, using Sing
+instance (HasSpine sop) => HasSpine (Maybe sop) where
+  type Spine (Maybe sop) = Maybe (Spine sop)
+  getSpine = fmap getSpine
 
 -- | Newtype encoding sop value of fixed known spine
 newtype OfSpine (x :: Spine datatype) = UnsafeMkOfSpine {getValue :: datatype}

src/Cardano/CEM.hs

@@ -125,6 +125,15 @@ data TransitionSpec script = MkTransitionSpec
   }
   deriving stock (Show)
 
+-- | List of all signing keys required for transition spec
+getAllSpecSigners :: TransitionSpec script -> [PubKeyHash]
+getAllSpecSigners spec = signers spec ++ txInPKHs
+  where
+    txInPKHs = mapMaybe getPubKey $ filter ((Prelude.== In) . txFanCKind) $ constraints spec
+    getPubKey c = case address (txFanCFilter c) of
+      ByPubKey key -> Just key
+      _ -> Nothing
+
 {- | Static part of CEMScript datum.
 Datatype is actually used only by off-chain code due to Plutus limitations.
 -}

src/Cardano/CEM/Examples/Auction.hs

@@ -105,7 +105,7 @@ instance CEMScript SimpleAuction where
                   (SumValueEq $ lot params)
               , nextState NotStarted
               ]
-          , signers = [seller params]
+          , signers = []
           }
     (Just NotStarted, Start) ->
       Right

src/Cardano/CEM/Monads/CLB.hs

@@ -77,16 +77,21 @@ instance (MonadFail m) => MonadSubmitTx (ClbT m) where
         result <- sendTx tx'
         case result of
           Success _ _ -> return $ Right $ getTxId body
-          _ -> fail "TODO"
+          Fail _ validationError ->
+            return $ Left $ UnhandledNodeSubmissionError validationError
       Right (_, _) -> fail "Unsupported tx format"
       Left e -> return $ Left $ UnhandledAutobalanceError e
 
 instance (MonadFail m) => MonadTest (ClbT m) where
   getTestWalletSks = return $ map intToCardanoSk [1 .. 10]
 
+genesisClbState :: Value -> ClbState
+genesisClbState genesisValue =
+  initClb defaultBabbage genesisValue genesisValue
+
 execOnIsolatedClb :: Value -> ClbT IO a -> IO a
 execOnIsolatedClb genesisValue action =
   fst
     <$> runStateT
       (unwrapClbT action)
-      (initClb defaultBabbage genesisValue genesisValue)
+      (genesisClbState genesisValue)

src/Cardano/CEM/Testing/StateMachine.hs

@@ -0,0 +1,268 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- | Generic utils for using `quickcheck-dynamic`
+module Cardano.CEM.Testing.StateMachine where
+
+import Prelude
+
+import Control.Monad (void)
+import Control.Monad.Trans (MonadIO (..))
+import Data.Bifunctor (Bifunctor (..))
+import Data.Data (Typeable)
+import Data.Maybe (mapMaybe)
+import Data.Set qualified as Set
+
+import PlutusLedgerApi.V1 (PubKeyHash)
+import PlutusTx.IsData (FromData (..))
+
+import Cardano.Api (PaymentKey, SigningKey, Value)
+
+import Clb (ClbT)
+import Test.QuickCheck
+import Test.QuickCheck.DynamicLogic (DynLogicModel)
+import Test.QuickCheck.Gen qualified as Gen
+import Test.QuickCheck.Monadic (monadic)
+import Test.QuickCheck.StateModel (
+  Actions,
+  Any (..),
+  Generic,
+  HasVariables (..),
+  Realized,
+  RunModel (..),
+  StateModel (..),
+  runActions,
+ )
+import Text.Show.Pretty (ppShow)
+
+import Cardano.CEM (CEMParams (..))
+import Cardano.CEM hiding (scriptParams)
+import Cardano.CEM.Monads (MonadSubmitTx)
+import Cardano.CEM.Monads.CLB
+import Cardano.CEM.OffChain
+import Cardano.CEM.OnChain (CEMScriptCompiled)
+import Cardano.Extras
+import Data.Spine (HasSpine (..))
+
+data ScriptStateParams a = MkScriptStateParams
+  { actors :: [SigningKey PaymentKey]
+  , cemParams :: CEMParams a
+  }
+  deriving stock (Generic)
+
+params :: ScriptStateParams script -> Params script
+params = scriptParams . cemParams
+
+deriving stock instance (Eq (CEMParams a)) => Eq (ScriptStateParams a)
+deriving stock instance (Show (CEMParams a)) => Show (ScriptStateParams a)
+
+data ScriptState a
+  = Void
+  | ActorsKnown [SigningKey PaymentKey]
+  | ScriptState
+      { dappParams :: ScriptStateParams a
+      , state :: Maybe (State a)
+      , involvedActors :: Set.Set PubKeyHash
+      , finished :: Bool
+      }
+  deriving stock (Generic)
+
+deriving stock instance
+  (Eq (State a), Eq (CEMParams a)) => Eq (ScriptState a)
+deriving stock instance
+  (Show (State a), Show (CEMParams a)) => Show (ScriptState a)
+
+instance HasVariables (ScriptState a) where
+  getAllVariables _ = Set.empty
+
+instance {-# OVERLAPS #-} HasVariables (Action (ScriptState script) a) where
+  getAllVariables _ = Set.empty
+
+class
+  ( CEMScriptCompiled script
+  , Show (Transition script)
+  , Show (State script)
+  , Show (CEMParams script)
+  , Eq (State script)
+  , Eq (CEMParams script)
+  , Eq (Transition script)
+  ) =>
+  CEMScriptArbitrary script
+  where
+  arbitraryCEMParams :: [SigningKey PaymentKey] -> Gen (CEMParams script)
+  arbitraryTransition ::
+    ScriptStateParams script -> Maybe (State script) -> Gen (Transition script)
+
+instance (CEMScriptArbitrary script) => StateModel (ScriptState script) where
+  data Action (ScriptState script) output where
+    SetupActors :: [SigningKey PaymentKey] -> Action (ScriptState script) ()
+    SetupCEMParams :: CEMParams script -> Action (ScriptState script) ()
+    ScriptTransition ::
+      Transition script -> Action (ScriptState script) ()
+    deriving stock (Typeable)
+
+  type Error (ScriptState script) = String
+
+  initialState = Void
+
+  actionName (ScriptTransition transition) = head . words . show $ transition
+  actionName SetupActors {} = "SetupActors"
+  actionName SetupCEMParams {} = "SetupCEMParams"
+
+  arbitraryAction _varCtx modelState = case modelState of
+    Void {} -> Gen.oneof [] -- SetupActors should be done manually
+    ActorsKnown actors ->
+      Some . SetupCEMParams <$> arbitraryCEMParams actors
+    ScriptState {dappParams, state} ->
+      Some . ScriptTransition <$> arbitraryTransition dappParams state
+
+  precondition Void (SetupActors {}) = True
+  precondition (ActorsKnown {}) (SetupCEMParams {}) = True
+  precondition
+    (ScriptState {dappParams, state, finished})
+    (ScriptTransition transition) =
+      case transitionSpec @script (params dappParams) state transition of
+        Right _ -> not finished
+        Left _ -> False
+  -- Unreachable
+  precondition _ _ = False
+
+  nextState Void (SetupActors actors) _var = ActorsKnown actors
+  nextState (ActorsKnown actors) (SetupCEMParams cemParams) _var =
+    ScriptState
+      { dappParams = MkScriptStateParams {actors, cemParams}
+      , state = Nothing
+      , involvedActors = Set.empty
+      , finished = False
+      }
+  nextState
+    as@ScriptState {dappParams, state}
+    (ScriptTransition transition)
+    _var =
+      case transitionSpec (params dappParams) state transition of
+        Right spec ->
+          as
+            { state = nextCEMState spec
+            , involvedActors =
+                involvedActors as
+                  <> Set.fromList (getAllSpecSigners spec)
+            , finished = nextCEMState spec == Nothing
+            }
+        Left _ -> error "Unreachable"
+      where
+        nextCEMState spec = case outStates spec of
+          [] -> Nothing
+          [state'] -> Just state'
+          _ ->
+            error
+              "This StateModel instance support only with single-output scripts"
+        outStates spec = mapMaybe decodeOutState $ constraints spec
+        decodeOutState c = case rest (txFanCFilter c) of
+          UnsafeBySameCEM stateBS ->
+            fromBuiltinData @(State script) stateBS
+          _ -> Nothing
+  nextState _ _ _ = error "Unreachable"
+
+instance (CEMScriptArbitrary script) => Show (Action (ScriptState script) a) where
+  show (ScriptTransition t) = "ScriptTransition " <> show t
+  show (SetupActors {}) = "SetupActors"
+  show (SetupCEMParams {}) = "SetupCEMParams"
+
+deriving stock instance
+  (CEMScriptArbitrary script) => Eq (Action (ScriptState script) a)
+
+instance (CEMScriptArbitrary script) => DynLogicModel (ScriptState script)
+
+-- RunModel
+
+type instance Realized (ClbT m) () = ()
+
+findSkForPKH :: [SigningKey PaymentKey] -> PubKeyHash -> SigningKey PaymentKey
+findSkForPKH sks phk = head $ filter (\x -> signingKeyToPKH x == phk) sks
+
+class (CEMScriptArbitrary script) => CEMScriptRunModel script where
+  performHook ::
+    (MonadIO m, MonadSubmitTx m) =>
+    ScriptState script ->
+    Action (ScriptState script) () ->
+    m ()
+
+instance
+  ( Realized m () ~ ()
+  , MonadIO m
+  , MonadSubmitTx m
+  , CEMScriptArbitrary script
+  , CEMScriptRunModel script
+  ) =>
+  RunModel (ScriptState script) m
+  where
+  perform modelState action _lookup = do
+    case (modelState, action) of
+      (Void, SetupActors {}) -> do
+        _ <- performHook modelState action
+        return $ Right ()
+      (ActorsKnown {}, SetupCEMParams {}) -> do
+        _ <- performHook modelState action
+        return $ Right ()
+      (ScriptState {dappParams, state}, ScriptTransition transition) -> do
+        _ <- performHook modelState action
+        case transitionSpec (params dappParams) state transition of
+          Right spec -> do
+            r <-
+              resolveTxAndSubmit $
+                MkTxSpec
+                  { actions =
+                      [ MkSomeCEMAction $ MkCEMAction (cemParams dappParams) transition
+                      ]
+                  , specSigner = findSkForPKH (actors dappParams) $ signerPKH spec
+                  }
+            return $ bimap show (const ()) r
+          Left err -> return $ Left $ show err
+        where
+          signerPKH spec = case getAllSpecSigners spec of
+            [singleSigner] -> singleSigner
+            _ -> error "Transition should have exactly one signer"
+      (_, _) -> error "Unreachable"
+
+  monitoring (stateFrom, stateTo) _ _ _ prop = do
+    tabStateFrom $ labelIfFinished prop
+    where
+      isFinished (ScriptState {finished}) = finished
+      isFinished _ = False
+      labelIfFinished prop' =
+        if isFinished stateTo
+          then
+            tabulate
+              "Actors involved (in finished tests)"
+              [show $ length $ involvedActors stateTo]
+              $ label "Reached final state" prop'
+          else prop'
+      tabStateFrom prop' =
+        case stateFrom of
+          ScriptState {state} ->
+            tabulate "States (from)" [show $ getSpine state] prop'
+          _ -> prop'
+
+  monitoringFailure state _ _ err prop =
+    counterexample
+      ( "In model state "
+          <> ppShow state
+          <> "\nGot error from emulator: "
+          <> err
+      )
+      prop
+
+runActionsInClb ::
+  forall state.
+  (StateModel (ScriptState state), RunModel (ScriptState state) (ClbT IO)) =>
+  Value ->
+  Actions (ScriptState state) ->
+  Property
+runActionsInClb genesisValue actions =
+  monadic (ioProperty . execOnIsolatedClb genesisValue) $
+    void $
+      runActions @(ScriptState state) @(ClbT IO) actions
+
+-- Orphans
+
+instance HasVariables (SigningKey PaymentKey) where
+  getAllVariables _ = Set.empty

test/Auction.hs

@@ -201,6 +201,18 @@ auctionSpec = describe "Auction" $ do
     Just (CurrentBid currentBid) <- queryScriptState auctionParams
     liftIO $ currentBid `shouldBe` bid1
 
+    submitAndCheck $
+      MkTxSpec
+        { actions =
+            [ MkSomeCEMAction $
+                MkCEMAction
+                  auctionParams
+                  ( MakeBid $ MkBet (signingKeyToPKH bidder1) 4_000_000
+                  )
+            ]
+        , specSigner = bidder1
+        }
+
     submitAndCheck $
       MkTxSpec
         { actions =