Change remaining contestation period to deadline

CHANGELOG.md

@@ -10,12 +10,18 @@ changes.
 
 ## [0.8.0] - UNRELEASED
 
-- **BREAKING** Changed logs to improve legibility and trace on-chain posting errors
-  + Strip on-chain transactions logging to just TxId
-  + Rename `Processing` -> `Begin` and `Processed` -> `End`
-  + Added `PostingFailed` log entry
-
-- The `hydra-cluster` does require `--publish-scripts` or `--hydra-scripts-tx-id` now as it may be provided with pre-published hydra scripts.
+- **BREAKING** Keep track of `contestationDeadline` instead of `remainingContestationPeriod` and fix `ReadyToFanout`.
+  + Clients can now rely on `ReadyToFanout`, such that sending a `Fanout` input after seeing this output will never be "too early".
+  + The `HeadIsClosed` server output now contains the deadline instead of the remaining time.
+  + See `hydra-tui` for an example how to use the `contestationDeadline` and `ReadyToFanout`.
+  + See [ADR20](./docs/adr/2022-08-02_020-handling-time.md) for details and the rationale.
+
+- **BREAKING** Changed logs to improve legibility and trace on-chain posting errors.
+  + Strip chain layer logs to only contain `TxId` instead of full transactions in the nominal cases.
+  + Renamed log entry prefixes `Processing -> Begin` and `Processed -> End`.
+  + Added `PostingFailed` log entry.
+
+- **BREAKING** The `hydra-cluster` executable (our smoke test) does require `--publish-scripts` or `--hydra-scripts-tx-id` now as it may be provided with pre-published hydra scripts.
 
 - Added a `hydra-tools` executable, which provides basic commands to help working with Hydra Heads:
   + Generate a pair of Hydra keys

docs/adr/2022-08-02_020-handling-time.md

@@ -3,12 +3,12 @@ slug: 20
 title: |
   20. Handling time
 authors: []
-tags: [Proposed]
+tags: [Accepted]
 ---
 
 ## Status
 
-Proposed
+Accepted
 
 ## Context
 
@@ -58,6 +58,9 @@ Proposed
   - Ensures clients only see `ReadyToFanout` when a following `Fanout` would be really possible.
   - Makes the `Delay` effect redundant and we can remove it (only delay via reenqueue on the `Wait` outcome)
 
+* By introducing `Tick` events, `IOSim` will not be able to detect non-progress (deadlocks).
+  - This means we cannot rely on early exit of simulations anymore and need to determine meaningful simulation endings instead of `waitUntilTheEndOfTime`.
+
 * We get a first, rough notion of time for free in our L2 and can support "timed transactions" with same resolution as the L1.
   - Tracking time in the state makes it trivial to provide it to the ledger when we `applyTransaction`.
   - Of course we could extend the fidelity of this feature using the system clock for "dead reckoning" between blocks. The conversion of wall clock to slot could even be configurable using an L2 `slotLength` analogous to L1 (although we might not want/need this).

hydra-cluster/bench/Bench/EndToEnd.hs

@@ -21,7 +21,7 @@ import Control.Monad.Class.MonadSTM (
   writeTBQueue,
  )
 import Data.Aeson (Result (Error, Success), Value, encode, fromJSON, (.=))
-import Data.Aeson.Lens (key, _Array, _Number, _String)
+import Data.Aeson.Lens (key, _Array, _JSON, _Number, _String)
 import qualified Data.List as List
 import qualified Data.Map as Map
 import Data.Scientific (Scientific)
@@ -105,9 +105,14 @@ bench timeoutSeconds workDir dataset@Dataset{clientDatasets} clusterSize =
 
                 putTextLn "Closing the Head"
                 send leader $ input "Close" []
-                -- REVIEW: Why 60 * clusterSize?
-                waitMatch (fromIntegral $ 60 * clusterSize) leader $ \v ->
-                  guard (v ^? key "tag" == Just "ReadyToFanout")
+                deadline <- waitMatch 3 leader $ \v -> do
+                  guard $ v ^? key "tag" == Just "HeadIsClosed"
+                  v ^? key "contestationDeadline" . _JSON
+
+                -- Expect to see ReadyToFanout within 3 seconds after deadline
+                remainingTime <- diffUTCTime deadline <$> getCurrentTime
+                waitFor tracer (truncate $ remainingTime + 3) [leader] $
+                  output "ReadyToFanout" []
 
                 putTextLn "Finalizing the Head"
                 send leader $ input "Fanout" []

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -9,7 +9,7 @@ import CardanoClient (queryTip)
 import CardanoNode (RunningNode (..))
 import Control.Lens ((^?))
 import Data.Aeson (object, (.=))
-import Data.Aeson.Lens (key, _Number)
+import Data.Aeson.Lens (key, _JSON)
 import qualified Data.Set as Set
 import Hydra.Cardano.Api (Lovelace, TxId, selectLovelace)
 import Hydra.Cluster.Faucet (Marked (Fuel), queryMarkedUTxO, seedFromFaucet)
@@ -46,17 +46,13 @@ singlePartyHeadFullLifeCycle tracer workDir node@RunningNode{networkId} hydraScr
       output "HeadIsOpen" ["utxo" .= object mempty]
     -- Close head
     send n1 $ input "Close" []
-    remainingSeconds <- waitMatch 600 n1 $ \v -> do
+    deadline <- waitMatch 600 n1 $ \v -> do
       guard $ v ^? key "tag" == Just "HeadIsClosed"
-      v ^? key "remainingContestationPeriod" . _Number
-    -- Expect to see readyToFanout within 10 seconds after deadline
-    waitFor tracer (truncate $ remainingSeconds + 10) [n1] $
+      v ^? key "contestationDeadline" . _JSON
+    -- Expect to see ReadyToFanout within 3 seconds after deadline
+    remainingTime <- diffUTCTime deadline <$> getCurrentTime
+    waitFor tracer (truncate $ remainingTime + 3) [n1] $
       output "ReadyToFanout" []
-    -- FIXME: Ideally the 'ReadyToFanout' is only sent when it's really ready,
-    -- but the cardano-ledger only updates it's "current slot" when it sees a
-    -- block. So we wait for roughly 1-2 blocks here (if not fixable, should at
-    -- least configure this given the shelley genesis)
-    threadDelay (2 * 20)
     send n1 $ input "Fanout" []
     waitFor tracer 600 [n1] $
       output "HeadIsFinalized" ["utxo" .= object mempty]

hydra-cluster/test/Test/DirectChainSpec.hs

@@ -26,7 +26,7 @@ import Hydra.Cardano.Api (
  )
 import Hydra.Chain (
   Chain (..),
-  ChainEvent (Observation),
+  ChainEvent (Observation, Tick),
   HeadParameters (..),
   OnChainTx (..),
   PostChainTx (..),
@@ -224,18 +224,23 @@ spec = around showLogsOnFailure $ do
                 , signatures = aggregate [sign aliceSk snapshot]
                 }
 
-            fanoutDelay <-
-              alicesCallback `shouldSatisfyInTime` \case
-                Observation OnCloseTx{snapshotNumber, remainingContestationPeriod} ->
-                  -- FIXME(SN): should assert contestationDeadline > current
-                  Just (snapshotNumber == 1, remainingContestationPeriod)
-                _ ->
-                  Nothing
-
-            threadDelay (toEnum (fromEnum fanoutDelay))
+            deadline <-
+              waitMatch alicesCallback $ \case
+                Observation OnCloseTx{snapshotNumber, contestationDeadline}
+                  | snapshotNumber == 1 -> Just contestationDeadline
+                _ -> Nothing
+            now <- getCurrentTime
+            unless (deadline > now) $
+              failure $ "contestationDeadline in the past: " <> show deadline <> ", now: " <> show now
+            delayUntil deadline
+
+            waitMatch alicesCallback $ \case
+              Tick t | t > deadline -> Just ()
+              _ -> Nothing
             postTx $
               FanoutTx
                 { utxo = someUTxO
+                , contestationDeadline = deadline
                 }
             alicesCallback `observesInTime` OnFanoutTx
             failAfter 5 $
@@ -314,16 +319,17 @@ observesInTime mvar expected =
       Observation obs -> obs `shouldBe` expected
       _ -> go
 
-shouldSatisfyInTime :: MVar a -> (a -> Maybe (Bool, b)) -> IO b
-shouldSatisfyInTime mvar f =
-  failAfter 10 $ do
-    a <- takeMVar mvar
-    case f a of
-      Nothing ->
-        fail "predicate failed."
-      Just (predicate, b) -> do
-        shouldSatisfy predicate identity
-        return b
+waitMatch :: MVar a -> (a -> Maybe b) -> IO b
+waitMatch mvar match = do
+  a <- takeMVar mvar
+  case match a of
+    Nothing -> waitMatch mvar match
+    Just b -> pure b
 
 isIntersectionNotFoundException :: IntersectionNotFoundException -> Bool
 isIntersectionNotFoundException _ = True
+
+delayUntil :: (MonadDelay m, MonadTime m) => UTCTime -> m ()
+delayUntil target = do
+  now <- getCurrentTime
+  threadDelay . realToFrac $ diffUTCTime target now

hydra-cluster/test/Test/EndToEndSpec.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 
@@ -13,7 +12,7 @@ import CardanoNode (RunningNode (..), withCardanoNodeDevnet)
 import Control.Lens ((^?))
 import Data.Aeson (Result (..), Value (Null, Object, String), fromJSON, object, (.=))
 import qualified Data.Aeson as Aeson
-import Data.Aeson.Lens (key)
+import Data.Aeson.Lens (key, _JSON)
 import qualified Data.ByteString as BS
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -28,9 +27,7 @@ import Hydra.Cardano.Api (
   lovelaceToValue,
   mkVkAddress,
   serialiseAddress,
-  unSlotNo,
  )
-import Hydra.Chain.Direct.Handlers (closeGraceTime)
 import Hydra.Cluster.Faucet (
   Marked (Fuel, Normal),
   publishHydraScriptsAs,
@@ -122,7 +119,7 @@ spec = around showLogsOnFailure $ do
                 seedFromFaucet_ node bobCardanoVk 100_000_000 Fuel
                 seedFromFaucet_ node carolCardanoVk 100_000_000 Fuel
 
-                let contestationPeriod = 2
+                let contestationPeriod = 2 :: Natural
 
                 send n1 $ input "Init" ["contestationPeriod" .= contestationPeriod]
                 waitFor tracer 10 [n1, n2, n3] $
@@ -140,14 +137,15 @@ spec = around showLogsOnFailure $ do
                 waitFor tracer 10 [n1, n2, n3] $ output "HeadIsOpen" ["utxo" .= u0]
 
                 send n1 $ input "Close" []
-                waitMatch 3 n1 $ \v -> do
+                deadline <- waitMatch 3 n1 $ \v -> do
                   guard $ v ^? key "tag" == Just "HeadIsClosed"
                   snapshotNumber <- v ^? key "snapshotNumber"
                   guard $ snapshotNumber == Aeson.Number 0
+                  v ^? key "contestationDeadline" . _JSON
 
-                -- 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] $
+                -- Expect to see ReadyToFanout within 3 seconds after deadline
+                remainingTime <- diffUTCTime deadline <$> getCurrentTime
+                waitFor tracer (truncate $ remainingTime + 3) [n1] $
                   output "ReadyToFanout" []
 
                 send n1 $ input "Fanout" []
@@ -307,7 +305,7 @@ spec = around showLogsOnFailure $ do
                     send n1 $ input "Init" ["contestationPeriod" .= int 10]
                     waitFor tracer 3 [n1] $ output "ReadyToCommit" ["parties" .= Set.fromList [alice, bob, carol]]
                     metrics <- getMetrics n1
-                    metrics `shouldSatisfy` ("hydra_head_events  5" `BS.isInfixOf`)
+                    metrics `shouldSatisfy` ("hydra_head_events" `BS.isInfixOf`)
 
     describe "hydra-node executable" $
       it "display proper semantic version given it is passed --version argument" $ \_ ->
@@ -343,7 +341,7 @@ initAndClose tracer clusterIx hydraScriptsTxId node@RunningNode{nodeSocket} = do
       seedFromFaucet_ node bobCardanoVk 100_000_000 Fuel
       seedFromFaucet_ node carolCardanoVk 100_000_000 Fuel
 
-      let contestationPeriod = 2
+      let contestationPeriod = 2 :: Natural
 
       send n1 $ input "Init" ["contestationPeriod" .= contestationPeriod]
       waitFor tracer 10 [n1, n2, n3] $
@@ -415,14 +413,15 @@ initAndClose tracer clusterIx hydraScriptsTxId node@RunningNode{nodeSocket} = do
       waitFor tracer 10 [n1] $ output "GetUTxOResponse" ["utxo" .= newUTxO]
 
       send n1 $ input "Close" []
-      waitMatch 3 n1 $ \v -> do
+      deadline <- waitMatch 3 n1 $ \v -> do
         guard $ v ^? key "tag" == Just "HeadIsClosed"
         snapshotNumber <- v ^? key "snapshotNumber"
         guard $ snapshotNumber == toJSON expectedSnapshotNumber
+        v ^? key "contestationDeadline" . _JSON
 
-      -- 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] $
+      -- Expect to see ReadyToFanout within 3 seconds after deadline
+      remainingTime <- diffUTCTime deadline <$> getCurrentTime
+      waitFor tracer (truncate $ remainingTime + 3) [n1] $
         output "ReadyToFanout" []
 
       send n1 $ input "Fanout" []

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

@@ -26,6 +26,7 @@ import Hydra.Chain.Direct.Context (
   genStClosed,
   genStInitial,
   genStOpen,
+  getContestationDeadline,
   pickChainContext,
   unsafeObserveInitAndCommits,
  )
@@ -36,7 +37,6 @@ import Hydra.Chain.Direct.State (
   commit,
   contest,
   fanout,
-  getContestationDeadline,
   getKnownUTxO,
   initialize,
   observeClose,
@@ -54,7 +54,7 @@ import Hydra.Ledger.Cardano.Evaluate (
   maxCpu,
   maxMem,
   maxTxSize,
-  slotNoFromPOSIXTime,
+  slotNoFromUTCTime,
  )
 import Hydra.Snapshot (genConfirmedSnapshot)
 import Plutus.Orphans ()
@@ -210,7 +210,7 @@ computeFanOutCost = do
     closePoint <- genPointInTime
     let closeTx = close stOpen snapshot closePoint
     let stClosed = snd . fromJust $ observeClose stOpen closeTx
-    let deadlineSlotNo = slotNoFromPOSIXTime (getContestationDeadline stClosed)
+    let deadlineSlotNo = slotNoFromUTCTime (getContestationDeadline stClosed)
     pure (getKnownUTxO stClosed, fanout stClosed utxo deadlineSlotNo)
 
 newtype NumParties = NumParties Int