From ce6e38c4d7cf70c0e6131ab75b23b238bb334d4a Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 29 Jul 2021 12:02:53 +0200 Subject: [PATCH] Add InitialParams and deserialize them as HeadParameters when watching init --- hydra-node/src/Hydra/Chain/ExternalPAB.hs | 12 ++++---- .../test/Hydra/Chain/ExternalPABSpec.hs | 12 ++++++-- .../src/Hydra/Contract/ContestationPeriod.hs | 4 +++ hydra-plutus/src/Hydra/Contract/Party.hs | 4 +++ hydra-plutus/src/Hydra/ContractSM.hs | 28 +++++++++++++------ 5 files changed, 43 insertions(+), 17 deletions(-) diff --git a/hydra-node/src/Hydra/Chain/ExternalPAB.hs b/hydra-node/src/Hydra/Chain/ExternalPAB.hs index bb8706839e0..c4f87ad744b 100644 --- a/hydra-node/src/Hydra/Chain/ExternalPAB.hs +++ b/hydra-node/src/Hydra/Chain/ExternalPAB.hs @@ -86,7 +86,7 @@ activateContract contract wallet = where reqBody = ActivateContractRequest (show contract) wallet --- XXX(SN): Not using the same type on both ends as having a too complicated +-- NOTE(SN): Not using the same type on both ends as having a too complicated -- 'Party' type to be able to use it properly in plutus ('Lift' and 'IsData' -- instances), and this would also be annoying in the dependency management. data PostInitParams = PostInitParams @@ -121,7 +121,8 @@ postInitTx cid params = data ActivateContractRequest = ActivateContractRequest {caID :: Text, caWallet :: Wallet} deriving (Generic, ToJSON) --- TODO(SN): DRY subscribers +-- TODO(SN): DRY subscribers and proper error handling + initTxSubscriber :: Wallet -> (OnChainTx tx -> IO ()) -> IO () initTxSubscriber wallet callback = do cid <- unContractInstanceId <$> activateContract WatchInit wallet @@ -133,10 +134,9 @@ initTxSubscriber wallet callback = do Error err -> say $ "decoding error json: " <> show err Success res -> case getLast res of Nothing -> pure () - Just ((contestationPeriod, parties) :: (ContestationPeriod, [Party])) -> do - -- TODO(SN): add tests for checking correspondence of json serialization - say $ "Observed Init tx with datum:" ++ show (contestationPeriod, parties) - callback $ InitTx (HeadParameters contestationPeriod parties) + Just (parameters :: HeadParameters) -> do + say $ "Observed Init tx with parameters:" ++ show parameters + callback $ InitTx parameters Right _ -> pure () Left err -> say $ "error decoding msg: " <> show err diff --git a/hydra-node/test/Hydra/Chain/ExternalPABSpec.hs b/hydra-node/test/Hydra/Chain/ExternalPABSpec.hs index 02f43c73012..7488393009e 100644 --- a/hydra-node/test/Hydra/Chain/ExternalPABSpec.hs +++ b/hydra-node/test/Hydra/Chain/ExternalPABSpec.hs @@ -26,8 +26,8 @@ spec = do -- We use slightly different types in off-chain and on-chain code, BUT, they -- have identical wire formats. We use (JSON) serialization as a mean to turn -- one into the other. - describe "OnChain / OffChain Serialization Roundtrips" $ - prop "PostInitParams -> InitParams" $ \(params :: PostInitParams) -> + describe "OffChain <-> OnChain Serialization" $ do + prop "PostInitParams -> Onchain.InitParams" $ \(params :: PostInitParams) -> let bytes = Aeson.encode params in counterexample (decodeUtf8 bytes) $ case Aeson.eitherDecode bytes of Left e -> @@ -35,6 +35,14 @@ spec = do Right (_ :: OnChain.InitParams) -> property True + prop "HeadParameters <- Onchain.InitialParams" $ \(params :: OnChain.InitialParams) -> + let bytes = Aeson.encode params + in counterexample (decodeUtf8 bytes) $ case Aeson.eitherDecode bytes of + Left e -> + counterexample ("Failed to decode: " <> show e) $ property False + Right (_ :: HeadParameters) -> + property True + describe "ExternalPAB" $ do it "publishes init tx using wallet 1 and observes it also" $ do failAfter 40 $ diff --git a/hydra-plutus/src/Hydra/Contract/ContestationPeriod.hs b/hydra-plutus/src/Hydra/Contract/ContestationPeriod.hs index c22f9cdc51b..f9b8748b837 100644 --- a/hydra-plutus/src/Hydra/Contract/ContestationPeriod.hs +++ b/hydra-plutus/src/Hydra/Contract/ContestationPeriod.hs @@ -14,6 +14,10 @@ newtype ContestationPeriod = UnsafeContestationPeriod {picoseconds :: Integer} PlutusTx.unstableMakeIsData ''ContestationPeriod +instance Arbitrary ContestationPeriod where + shrink = genericShrink + arbitrary = genericArbitrary + instance FromJSON ContestationPeriod where parseJSON = fmap (UnsafeContestationPeriod . diffTimeToPicoseconds) . parseJSON diff --git a/hydra-plutus/src/Hydra/Contract/Party.hs b/hydra-plutus/src/Hydra/Contract/Party.hs index 335742ffed5..29ba1939209 100644 --- a/hydra-plutus/src/Hydra/Contract/Party.hs +++ b/hydra-plutus/src/Hydra/Contract/Party.hs @@ -20,6 +20,10 @@ newtype Party = UnsafeParty Integer -- (VerKeyDSIGN MockDSIGN) PlutusTx.makeLift ''Party +instance Arbitrary Party where + shrink = genericShrink + arbitrary = genericArbitrary + instance ToJSON Party where toJSON (UnsafeParty i) = toJSON i diff --git a/hydra-plutus/src/Hydra/ContractSM.hs b/hydra-plutus/src/Hydra/ContractSM.hs index 07ea3526c96..25659afe7fd 100644 --- a/hydra-plutus/src/Hydra/ContractSM.hs +++ b/hydra-plutus/src/Hydra/ContractSM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-specialize #-} @@ -6,15 +7,13 @@ -- between Node and Chain module Hydra.ContractSM where +import Hydra.Prelude hiding (State, find, fmap, foldMap, map, mapMaybe, mempty, pure, zip, ($), (&&), (+), (<$>), (<>), (==)) +import PlutusTx.Prelude hiding (Eq) + import Control.Lens (makeClassyPrisms) -import Control.Monad (forever) -import Data.Aeson (FromJSON, ToJSON) -import Data.Either (rights) import qualified Data.Map as Map -import GHC.Generics (Generic) import Hydra.Contract.ContestationPeriod (ContestationPeriod) import Hydra.Contract.Party (Party) -import Hydra.Prelude (Eq, Last (..), Show, String, show, uncurry, void) import Ledger (CurrencySymbol, PubKeyHash (..), TxOut (txOutValue), TxOutTx (txOutTxOut), Value, pubKeyAddress, pubKeyHash) import Ledger.AddressMap (outputsMapFromTxForAddress) import Ledger.Constraints (mustPayToPubKey) @@ -39,7 +38,6 @@ import Plutus.Contract.StateMachine (StateMachine, StateMachineClient, WaitingRe import qualified Plutus.Contract.StateMachine as SM import qualified Plutus.Contracts.Currency as Currency import qualified PlutusTx -import PlutusTx.Prelude hiding (Eq) data State = Setup @@ -158,7 +156,7 @@ data InitParams = InitParams , cardanoPubKeys :: [PubKeyHash] , hydraParties :: [Party] } - deriving (Show, Generic, FromJSON, ToJSON) + deriving (Generic, Show, FromJSON, ToJSON) setup :: Contract () (Endpoint "init" InitParams) HydraPlutusError () setup = do @@ -185,9 +183,20 @@ setup = do void $ SM.runStep client (Init contestationPeriod (zip cardanoPubKeys tokenValues) hydraParties) logInfo $ "Triggered Init " <> show @String cardanoPubKeys +-- | Parameters as they are available in the 'Initial' state. +data InitialParams = InitialParams + { contestationPeriod :: ContestationPeriod + , parties :: [Party] + } + deriving (Generic, Show, FromJSON, ToJSON) + +instance Arbitrary InitialParams where + shrink = genericShrink + arbitrary = genericArbitrary + -- | Watch 'initialAddress' (with hard-coded parameters) and report all datums -- seen on each run. -watchInit :: Contract (Last (ContestationPeriod, [Party])) Empty ContractError () +watchInit :: Contract (Last InitialParams) Empty ContractError () watchInit = do logInfo @String $ "watchInit: Looking for an init tx and it's parties" pubKey <- ownPubKey @@ -202,7 +211,8 @@ watchInit = do let datums = txs >>= rights . fmap (lookupDatum token) . Map.elems . outputsMapFromTxForAddress (scriptAddress token) logInfo @String $ "found init tx(s) with datums: " <> show datums case datums of - [Initial contestationPeriod parties] -> tell $ Last $ Just (contestationPeriod, parties) + [Initial contestationPeriod parties] -> + tell . Last . Just $ InitialParams{contestationPeriod, parties} _ -> pure () _ -> pure () where