Merge pull request #359 from input-output-hk/ensemble/192/fanout-dead…

…line

Ensemble/192/fanout deadline

.github/workflows/ci.yaml

@@ -38,8 +38,8 @@ jobs:
       with:
         skip_adding_nixpkgs_channel: true
         extra_nix_config: |
-          trusted-public-keys = iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
-          substituters = https://cache.nixos.org https://hydra.iohk.io https://iohk.cachix.org
+          trusted-public-keys = iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.iog.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
+          substituters = https://cache.nixos.org https://cache.iog.io https://iohk.cachix.org
 
     - name: Cachix cache of nix derivations
       uses: cachix/cachix-action@v10
@@ -136,8 +136,8 @@ jobs:
       with:
         skip_adding_nixpkgs_channel: true
         extra_nix_config: |
-          trusted-public-keys = iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
-          substituters = https://cache.nixos.org https://hydra.iohk.io https://iohk.cachix.org
+          trusted-public-keys = iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.iog.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
+          substituters = https://cache.nixos.org https://cache.iog.io https://iohk.cachix.org
 
     - name: Cachix cache of nix derivations
       uses: cachix/cachix-action@v10

hydra-cluster/config/genesis-shelley.json

@@ -4,7 +4,7 @@
         "poolDeposit": 0,
         "protocolVersion": {
             "minor": 0,
-            "major": 0
+            "major": 6
         },
         "minUTxOValue": 0,
         "decentralisationParam": 1,

hydra-cluster/test/Test/DirectChainSpec.hs

@@ -27,6 +27,7 @@ import Hydra.Cardano.Api (
   ChainPoint (..),
   lovelaceToValue,
   txOutValue,
+  unSlotNo,
   unsafeDeserialiseFromRawBytesBase16,
  )
 import Hydra.Chain (
@@ -40,6 +41,7 @@ import Hydra.Chain (
 import Hydra.Chain.Direct (
   DirectChainLog,
   IntersectionNotFoundException,
+  closeGraceTime,
   withDirectChain,
   withIOManager,
  )
@@ -192,8 +194,8 @@ spec = around showLogsOnFailure $ do
           withDirectChain (contramap (FromDirectChain "alice") tracer) defaultNetworkId iocp nodeSocket aliceKeys alice cardanoKeys Nothing (putMVar alicesCallback) $ \Chain{postTx} -> do
             seedFromFaucet_ defaultNetworkId node aliceCardanoVk 100_000_000 Fuel
 
-            postTx $ InitTx $ HeadParameters 100 [alice]
-            alicesCallback `observesInTime` OnInitTx 100 [alice]
+            postTx $ InitTx $ HeadParameters 1 [alice]
+            alicesCallback `observesInTime` OnInitTx 1 [alice]
 
             someUTxO <- seedFromFaucet defaultNetworkId node aliceCardanoVk 1_000_000 Normal
             postTx $ CommitTx alice someUTxO
@@ -222,6 +224,9 @@ spec = around showLogsOnFailure $ do
               _ ->
                 False
 
+            -- TODO: compute from chain parameters
+            -- contestation period + closeGraceTime * slot length
+            threadDelay $ 1 + (fromIntegral (unSlotNo closeGraceTime) * 0.1)
             postTx $
               FanoutTx
                 { utxo = someUTxO

hydra-cluster/test/Test/EndToEndSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 module Test.EndToEndSpec where
@@ -34,7 +35,9 @@ import Hydra.Cardano.Api (
   lovelaceToValue,
   mkVkAddress,
   serialiseAddress,
+  unSlotNo,
  )
+import Hydra.Chain.Direct (closeGraceTime)
 import Hydra.Crypto (deriveVerificationKey, generateSigningKey)
 import qualified Hydra.Crypto as Hydra
 import Hydra.Ledger (txId)
@@ -273,7 +276,8 @@ initAndClose tracer clusterIx node@(RunningNode _ nodeSocket) = do
       seedFromFaucet_ defaultNetworkId node bobCardanoVk 100_000_000 Fuel
       seedFromFaucet_ defaultNetworkId node carolCardanoVk 100_000_000 Fuel
 
-      let contestationPeriod = 10 :: Natural
+      let contestationPeriod = 2
+
       send n1 $ input "Init" ["contestationPeriod" .= contestationPeriod]
       waitFor tracer 10 [n1, n2, n3] $
         output "ReadyToCommit" ["parties" .= Set.fromList [alice, bob, carol]]
@@ -341,7 +345,9 @@ initAndClose tracer clusterIx node@(RunningNode _ nodeSocket) = do
         snapshotNumber <- v ^? key "snapshotNumber"
         guard $ snapshotNumber == toJSON expectedSnapshotNumber
 
-      waitFor tracer (contestationPeriod + 3) [n1] $
+      -- NOTE: We expect the head to be finalized after the contestation period
+      -- and some three secs later, plus the closeGraceTime * slotLength
+      waitFor tracer (truncate $ contestationPeriod + (fromIntegral @_ @Double (unSlotNo closeGraceTime) * 0.1) + 3) [n1] $
         output "HeadIsFinalized" ["utxo" .= newUTxO]
 
       case fromJSON $ toJSON newUTxO of

hydra-cluster/test/Test/LogFilterSpec.hs

@@ -43,6 +43,6 @@ spec = parallel $ do
         filtered = encode $ mapMaybe filterLog jsonLogs
         sizeRatio = fromIntegral (LBS.length filtered) * (100.0 :: Double) / fromIntegral (LBS.length bytes)
      in LBS.length filtered < LBS.length bytes && sizeRatio > 0
-          & cover 0.9 (sizeRatio < 10.0) "reduces size by 90%"
+          & cover 40 (sizeRatio < 10.0) "reduces size by 90%"
           & tabulate "Ratios" [show (floor (sizeRatio / 10) * 10 :: Int) <> " %"]
           & checkCoverage

hydra-node/exe/tx-cost/TxCost.hs

@@ -46,7 +46,7 @@ import Hydra.Ledger.Cardano (
   genTxIn,
   simplifyUTxO,
  )
-import Hydra.Ledger.Cardano.Evaluate (evaluateTx, pparams)
+import Hydra.Ledger.Cardano.Evaluate (evaluateTx, genPointInTime, pparams)
 import Plutus.Orphans ()
 import Test.QuickCheck (generate, sublistOf, vectorOf)
 
@@ -164,7 +164,8 @@ computeFanOutCost = do
     ctx <- genHydraContext 3
     let utxo = genSimpleUTxOOfSize numOutputs `generateWith` 42
     (_, stClosed) <- genStClosed ctx utxo
-    pure (fanout utxo stClosed, getKnownUTxO stClosed)
+    pointInTime <- genPointInTime
+    pure (fanout utxo pointInTime stClosed, getKnownUTxO stClosed)
 
 genSimpleUTxOOfSize :: Int -> Gen UTxO
 genSimpleUTxOOfSize numUTxO =

hydra-node/json-schemas/logs.yaml

@@ -891,13 +891,17 @@ definitions:
         required:
         - tag
         - snapshotNumber
+        - remainingContestationPeriod
         properties:
           tag:
             type: string
             enum: ["OnCloseTx"]
           snapshotNumber:
             type: integer
             minimum: 0
+          remainingContestationPeriod:
+            type: integer
+            minimum: 0
       - title: OnContestTx
         type: object
         additionalProperties: false

hydra-node/src/Hydra/Chain.hs

@@ -25,7 +25,7 @@ import Hydra.Snapshot (ConfirmedSnapshot, SnapshotNumber)
 
 -- | Contains the head's parameters as established in the initial transaction.
 data HeadParameters = HeadParameters
-  { contestationPeriod :: DiffTime
+  { contestationPeriod :: NominalDiffTime
   , parties :: [Party] -- NOTE(SN): The order of this list is important for leader selection.
   }
   deriving stock (Eq, Show, Generic)
@@ -34,7 +34,7 @@ data HeadParameters = HeadParameters
 instance Arbitrary HeadParameters where
   arbitrary = genericArbitrary
 
-type ContestationPeriod = DiffTime
+type ContestationPeriod = NominalDiffTime
 
 -- | Data type used to post transactions on chain. It holds everything to
 -- construct corresponding Head protocol transactions.
@@ -82,7 +82,12 @@ data OnChainTx tx
   | OnCommitTx {party :: Party, committed :: UTxOType tx}
   | OnAbortTx
   | OnCollectComTx
-  | OnCloseTx {snapshotNumber :: SnapshotNumber}
+  | OnCloseTx
+      { snapshotNumber :: SnapshotNumber
+      , -- | The remaining contestation period in wall clock time calculated
+        -- from the actual upper bound of the close transaction observed.
+        remainingContestationPeriod :: NominalDiffTime
+      }
   | OnContestTx {snapshotNumber :: SnapshotNumber}
   | OnFanoutTx
   deriving (Generic)

hydra-node/src/Hydra/Chain/Direct.hs

@@ -100,12 +100,14 @@ import Hydra.Chain.Direct.State (
   commit,
   contest,
   fanout,
+  getContestationDeadline,
   getKnownUTxO,
   idleOnChainHeadState,
   initialize,
   observeSomeTx,
   reifyState,
  )
+import Hydra.Chain.Direct.Tx (PointInTime)
 import Hydra.Chain.Direct.Util (
   Block,
   Era,
@@ -122,6 +124,7 @@ import Hydra.Chain.Direct.Wallet (
   getTxId,
   withTinyWallet,
  )
+import Hydra.Data.ContestationPeriod (posixToUTCTime)
 import Hydra.Logging (Tracer, traceWith)
 import Hydra.Party (Party)
 import Ouroboros.Consensus.Cardano.Block (EraMismatch, GenTx (..), HardForkApplyTxErr (ApplyTxErrAlonzo), HardForkBlock (BlockAlonzo))
@@ -163,7 +166,6 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client (
   SubmitResult (..),
   localTxSubmissionClientPeer,
  )
-import Plutus.V1.Ledger.Api (POSIXTime)
 import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
 
 withDirectChain ::
@@ -266,11 +268,11 @@ withDirectChain tracer networkId iocp socketPath keyPair party cardanoKeys point
         }
 
 data TimeHandle m = TimeHandle
-  { currentSlot :: m SlotNo
-  , -- | Convert some slot into an absolute point in time.
-    -- It throws an exception when requesting a `SlotNo` that is
-    -- more than the current epoch length (5 days at time of writing this comment).
-    convertSlot :: MonadThrow m => SlotNo -> m POSIXTime
+  { -- | Get the current 'PointInTime'
+    currentPointInTime :: m PointInTime
+  , -- | Adjust a 'PointInTime' by some number of slots, positively or
+    -- negatively.
+    adjustPointInTime :: SlotNo -> PointInTime -> m PointInTime
   }
 
 -- | Query ad-hoc epoch, system start and protocol parameters to determine
@@ -282,14 +284,18 @@ queryTimeHandle networkId socketPath = do
   let epochInfo = toEpochInfo eraHistory
   pparams <- queryProtocolParameters networkId socketPath
   slotNo <- queryTipSlotNo networkId socketPath
+  let toTime =
+        slotToPOSIXTime
+          (toLedgerPParams ShelleyBasedEraAlonzo pparams :: PParams LedgerEra)
+          epochInfo
+          systemStart
   pure $
     TimeHandle
-      { currentSlot = pure slotNo
-      , convertSlot =
-          slotToPOSIXTime
-            (toLedgerPParams ShelleyBasedEraAlonzo pparams :: PParams LedgerEra)
-            epochInfo
-            systemStart
+      { currentPointInTime = (slotNo,) <$> toTime slotNo
+      , adjustPointInTime = \n (slot, _) -> do
+          let adjusted = slot + n
+          time <- toTime adjusted
+          pure (adjusted, time)
       }
  where
   toEpochInfo :: MonadThrow m => EraHistory CardanoMode -> EpochInfo m
@@ -382,7 +388,7 @@ data ChainSyncHandler m = ChainSyncHandler
 
 chainSyncHandler ::
   forall m.
-  (MonadSTM m) =>
+  (MonadSTM m, MonadTime m) =>
   -- | Tracer for logging
   Tracer m DirectChainLog ->
   -- | Chain callback
@@ -407,7 +413,8 @@ chainSyncHandler tracer callback headState =
   onRollForward :: Block -> m ()
   onRollForward blk = do
     let receivedTxs = toList $ getAlonzoTxs blk
-    onChainTxs <- reverse <$> atomically (foldM (withNextTx (blockPoint blk)) [] receivedTxs)
+    now <- getCurrentTime
+    onChainTxs <- reverse <$> atomically (foldM (withNextTx now (blockPoint blk)) [] receivedTxs)
     unless (null receivedTxs) $
       traceWith tracer $
         ReceivedTxs
@@ -416,17 +423,26 @@ chainSyncHandler tracer callback headState =
           }
     mapM_ (callback . Observation) onChainTxs
 
-  withNextTx :: Point Block -> [OnChainTx Tx] -> ValidatedTx Era -> STM m [OnChainTx Tx]
-  withNextTx point observed (fromLedgerTx -> tx) = do
+  -- NOTE: We pass 'now' or current time because we need it for observing passing of time in the
+  -- contestation phase.
+  withNextTx :: UTCTime -> Point Block -> [OnChainTx Tx] -> ValidatedTx Era -> STM m [OnChainTx Tx]
+  withNextTx now point observed (fromLedgerTx -> tx) = do
     st <- readTVar headState
     case observeSomeTx tx (currentOnChainHeadState st) of
-      Just (onChainTx, st') -> do
+      Just (onChainTx, st'@(SomeOnChainHeadState nextState)) -> do
         writeTVar headState $
           SomeOnChainHeadStateAt
             { currentOnChainHeadState = st'
             , recordedAt = AtPoint (fromConsensusPointHF point) st
             }
-        pure $ onChainTx : observed
+        -- FIXME: The right thing to do is probably to decouple the observation from the
+        -- transformation into an `OnChainTx`
+        let event = case (onChainTx, reifyState nextState) of
+              (OnCloseTx{snapshotNumber}, TkClosed) ->
+                let remainingTimeWithBuffer = 1 + diffUTCTime (posixToUTCTime $ getContestationDeadline nextState) now
+                 in OnCloseTx{snapshotNumber, remainingContestationPeriod = remainingTimeWithBuffer}
+              _ -> onChainTx
+        pure $ event : observed
       Nothing ->
         pure observed
 
@@ -605,7 +621,6 @@ finalizeTx TinyWallet{sign, getUTxO, coverFee} headState partialTx = do
       pure $ sign validatedTx
 
 -- | Hardcoded grace time for close transaction to be valid.
--- TODO: replace/remove with deadline contestation
 -- TODO: make it a node configuration parameter
 closeGraceTime :: SlotNo
 closeGraceTime = 100
@@ -618,7 +633,8 @@ fromPostChainTx ::
   TVar m SomeOnChainHeadStateAt ->
   PostChainTx Tx ->
   STM m Tx
-fromPostChainTx TimeHandle{currentSlot, convertSlot} cardanoKeys wallet someHeadState tx = do
+fromPostChainTx TimeHandle{currentPointInTime, adjustPointInTime} cardanoKeys wallet someHeadState tx = do
+  pointInTime <- currentPointInTime
   SomeOnChainHeadState st <- currentOnChainHeadState <$> readTVar someHeadState
   case (tx, reifyState st) of
     (InitTx params, TkIdle) -> do
@@ -644,15 +660,13 @@ fromPostChainTx TimeHandle{currentSlot, convertSlot} cardanoKeys wallet someHead
     (CollectComTx{}, TkInitialized) -> do
       pure (collect st)
     (CloseTx{confirmedSnapshot}, TkOpen) -> do
-      slot <- (+ closeGraceTime) <$> currentSlot
-      posixTime <- convertSlot slot
-      pure (close confirmedSnapshot (slot, posixTime) st)
+      shifted <- adjustPointInTime closeGraceTime pointInTime
+      pure (close confirmedSnapshot shifted st)
     (ContestTx{confirmedSnapshot}, TkClosed) -> do
-      slot <- (+ closeGraceTime) <$> currentSlot
-      posixTime <- convertSlot slot
-      pure (contest confirmedSnapshot (slot, posixTime) st)
+      shifted <- adjustPointInTime closeGraceTime pointInTime
+      pure (contest confirmedSnapshot shifted st)
     (FanoutTx{utxo}, TkClosed) ->
-      pure (fanout utxo st)
+      pure (fanout utxo pointInTime st)
     (_, _) ->
       throwIO $ InvalidStateToPost tx
 

hydra-node/src/Hydra/Chain/Direct/Context.hs

@@ -22,17 +22,18 @@ import Hydra.Chain.Direct.State (
   collect,
   commit,
   contest,
+  fanout,
   getContestationDeadline,
   idleOnChainHeadState,
   initialize,
   observeTx,
  )
 import qualified Hydra.Crypto as Hydra
-import Hydra.Ledger.Cardano (genOneUTxOFor, genTxIn, genVerificationKey, renderTx)
+import Hydra.Ledger.Cardano (genOneUTxOFor, genTxIn, genUTxO, genVerificationKey, renderTx, simplifyUTxO)
 import Hydra.Ledger.Cardano.Evaluate (genPointInTime, slotNoToPOSIXTime)
 import Hydra.Party (Party, deriveParty)
 import Hydra.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber, genConfirmedSnapshot, getSnapshot)
-import Test.QuickCheck (choose, elements, frequency, suchThat, vector)
+import Test.QuickCheck (choose, elements, frequency, resize, suchThat, vector)
 
 -- | Define some 'global' context from which generators can pick
 -- values for generation. This allows to write fairly independent generators
@@ -45,7 +46,7 @@ data HydraContext = HydraContext
   { ctxVerificationKeys :: [VerificationKey PaymentKey]
   , ctxHydraSigningKeys :: [Hydra.SigningKey]
   , ctxNetworkId :: NetworkId
-  , ctxContestationPeriod :: DiffTime
+  , ctxContestationPeriod :: NominalDiffTime
   }
   deriving (Show)
 
@@ -157,6 +158,17 @@ genContestTx numParties = do
       slotNoToPOSIXTime slot < getContestationDeadline stClosed
   pure (stClosed, contest snapshot pointInTime stClosed)
 
+genFanoutTx :: Int -> Gen (OnChainHeadState 'StClosed, Tx)
+genFanoutTx numParties = do
+  ctx <- genHydraContext numParties
+  let maxAssetsSupported = 1
+  utxo <- resize maxAssetsSupported $ simplifyUTxO <$> genUTxO
+  (_, stClosed) <- genStClosed ctx utxo
+  pointInTime <-
+    genPointInTime `suchThat` \(slot, _) ->
+      slotNoToPOSIXTime slot > getContestationDeadline stClosed
+  pure (stClosed, fanout utxo pointInTime stClosed)
+
 genStOpen ::
   HydraContext ->
   Gen (UTxO, OnChainHeadState 'StOpen)