Fix upper bound and deadline on drafted deposit txs

This switches the drafted tx deadline to be 3 * deposit period.

Author: ch1bo

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

@@ -318,14 +318,17 @@ nodeReObservesOnChainTxs tracer workDir cardanoNode hydraScriptsTxId = do
   refuelIfNeeded tracer cardanoNode Bob 100_000_000
   -- Start hydra-node on chain tip
   tip <- queryTip networkId nodeSocket
-  let contestationPeriod = 2
+
+  -- NOTE: Adapt periods to block times
+  let contestationPeriod = truncate $ 10 * blockTime
+      depositPeriod = truncate $ 50 * blockTime
   aliceChainConfig <-
     chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [Bob] contestationPeriod
-      <&> modifyConfig (\config -> config{startChainFrom = Nothing})
+      <&> modifyConfig (\config -> config{startChainFrom = Nothing, depositPeriod})
 
   bobChainConfig <-
     chainConfigFor Bob workDir nodeSocket hydraScriptsTxId [Alice] contestationPeriod
-      <&> modifyConfig (\config -> config{startChainFrom = Nothing})
+      <&> modifyConfig (\config -> config{startChainFrom = Nothing, depositPeriod})
 
   (aliceCardanoVk, aliceCardanoSk) <- keysFor Alice
   commitUTxO <- seedFromFaucet cardanoNode aliceCardanoVk 5_000_000 (contramap FromFaucet tracer)
@@ -355,10 +358,10 @@ nodeReObservesOnChainTxs tracer workDir cardanoNode hydraScriptsTxId = do
 
       submitTx cardanoNode tx
 
-      waitFor hydraTracer 10 [n1, n2] $
+      waitFor hydraTracer (2 * realToFrac depositPeriod) [n1, n2] $
         output "CommitApproved" ["headId" .= headId, "utxoToCommit" .= commitUTxO]
 
-      waitFor hydraTracer 10 [n1, n2] $
+      waitFor hydraTracer (20 * blockTime) [n1, n2] $
         output "CommitFinalized" ["headId" .= headId, "depositTxId" .= getTxId (getTxBody tx)]
 
       getSnapshotUTxO n1 `shouldReturn` commitUTxO
@@ -781,8 +784,12 @@ singlePartyCommitsScriptBlueprint ::
 singlePartyCommitsScriptBlueprint tracer workDir node hydraScriptsTxId =
   (`finally` returnFundsToFaucet tracer node Alice) $ do
     refuelIfNeeded tracer node Alice 20_000_000
-    let contestationPeriod = 100
-    aliceChainConfig <- chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod
+    -- NOTE: Adapt periods to block times
+    let contestationPeriod = truncate $ 10 * blockTime
+        depositPeriod = truncate $ 50 * blockTime
+    aliceChainConfig <-
+      chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod
+        <&> modifyConfig (\c -> c{depositPeriod})
     let hydraNodeId = 1
     let hydraTracer = contramap FromHydraNode tracer
     (_, walletSk) <- keysFor AliceFunds
@@ -826,9 +833,9 @@ singlePartyCommitsScriptBlueprint tracer workDir node hydraScriptsTxId =
 
       submitTx node tx
 
-      waitFor hydraTracer 10 [n1] $
+      waitFor hydraTracer (2 * realToFrac depositPeriod) [n1] $
         output "CommitApproved" ["headId" .= headId, "utxoToCommit" .= scriptUTxO']
-      waitFor hydraTracer 10 [n1] $
+      waitFor hydraTracer (20 * blockTime) [n1] $
         output "CommitFinalized" ["headId" .= headId, "depositTxId" .= getTxId (getTxBody tx)]
 
       getSnapshotUTxO n1 `shouldReturn` scriptUTxO <> scriptUTxO'
@@ -1172,9 +1179,9 @@ canCommit tracer workDir node hydraScriptsTxId =
     (`finally` returnFundsToFaucet tracer node Bob) $ do
       refuelIfNeeded tracer node Alice 30_000_000
       refuelIfNeeded tracer node Bob 30_000_000
-      -- NOTE: Deliberately low periods to speed up happy path test
-      let contestationPeriod = truncate $ 3 * blockTime
-          depositPeriod = truncate $ 5 * blockTime
+      -- NOTE: Adapt periods to block times
+      let contestationPeriod = truncate $ 10 * blockTime
+          depositPeriod = truncate $ 50 * blockTime
       aliceChainConfig <-
         chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [Bob] contestationPeriod
           <&> setNetworkId networkId
@@ -1186,12 +1193,12 @@ canCommit tracer workDir node hydraScriptsTxId =
       withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [bobVk] [2] $ \n1 -> do
         withHydraNode hydraTracer bobChainConfig workDir 2 bobSk [aliceVk] [1] $ \n2 -> do
           send n1 $ input "Init" []
-          headId <- waitMatch (2 * blockTime) n2 $ headIsInitializingWith (Set.fromList [alice, bob])
+          headId <- waitMatch (10 * blockTime) n2 $ headIsInitializingWith (Set.fromList [alice, bob])
 
           -- Commit nothing
           requestCommitTx n1 mempty >>= submitTx node
           requestCommitTx n2 mempty >>= submitTx node
-          waitFor hydraTracer (2 * blockTime) [n1, n2] $
+          waitFor hydraTracer (20 * blockTime) [n1, n2] $
             output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId]
 
           -- Get some L1 funds
@@ -1211,7 +1218,7 @@ canCommit tracer workDir node hydraScriptsTxId =
 
           waitFor hydraTracer (2 * realToFrac depositPeriod) [n1, n2] $
             output "CommitApproved" ["headId" .= headId, "utxoToCommit" .= commitUTxO]
-          waitFor hydraTracer (2 * blockTime) [n1, n2] $
+          waitFor hydraTracer (20 * blockTime) [n1, n2] $
             output "CommitFinalized" ["headId" .= headId, "depositTxId" .= getTxId (getTxBody tx)]
 
           getSnapshotUTxO n1 `shouldReturn` commitUTxO
@@ -1228,22 +1235,22 @@ canCommit tracer workDir node hydraScriptsTxId =
 
           waitFor hydraTracer (2 * realToFrac depositPeriod) [n1, n2] $
             output "CommitApproved" ["headId" .= headId, "utxoToCommit" .= commitUTxO2]
-          waitFor hydraTracer (2 * blockTime) [n1, n2] $
+          waitFor hydraTracer (20 * blockTime) [n1, n2] $
             output "CommitFinalized" ["headId" .= headId, "depositTxId" .= getTxId (getTxBody tx')]
 
           getSnapshotUTxO n1 `shouldReturn` commitUTxO <> commitUTxO2
 
           send n2 $ input "Close" []
 
-          deadline <- waitMatch (2 * blockTime) n2 $ \v -> do
+          deadline <- waitMatch (10 * blockTime) n2 $ \v -> do
             guard $ v ^? key "tag" == Just "HeadIsClosed"
             v ^? key "contestationDeadline" . _JSON
 
           remainingTime <- diffUTCTime deadline <$> getCurrentTime
           waitFor hydraTracer (remainingTime + 3 * blockTime) [n1, n2] $
             output "ReadyToFanout" ["headId" .= headId]
           send n2 $ input "Fanout" []
-          waitMatch (2 * blockTime) n2 $ \v ->
+          waitMatch (10 * blockTime) n2 $ \v ->
             guard $ v ^? key "tag" == Just "HeadIsFinalized"
 
           -- Assert final wallet balance
@@ -1359,9 +1366,9 @@ canSeePendingDeposits tracer workDir node hydraScriptsTxId =
     (`finally` returnFundsToFaucet tracer node Bob) $ do
       refuelIfNeeded tracer node Alice 30_000_000
       refuelIfNeeded tracer node Bob 30_000_000
-      -- NOTE: Directly expire deposits
-      contestationPeriod <- CP.fromNominalDiffTime 1
-      let depositPeriod = 1
+      -- NOTE: Adapt periods to block times
+      let contestationPeriod = truncate $ 10 * blockTime
+          depositPeriod = truncate $ 50 * blockTime
       aliceChainConfig <-
         chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [Bob] contestationPeriod
           <&> setNetworkId networkId
@@ -1418,7 +1425,7 @@ canSeePendingDeposits tracer workDir node hydraScriptsTxId =
           let path = BSC.unpack $ urlEncode False $ encodeUtf8 $ T.pack $ show deposit
           -- XXX: should know the deadline from the query above
           -- NOTE: we need to wait for the deadline to pass before we can recover the deposit
-          threadDelay $ realToFrac (toNominalDiffTime depositPeriod * 2)
+          threadDelay $ realToFrac (toNominalDiffTime depositPeriod * 4)
 
           (`shouldReturn` "OK") $
             parseUrlThrow ("DELETE " <> hydraNodeBaseUrl n1 <> "/commits/" <> path)

hydra-node/src/Hydra/API/HTTPServer.hs

@@ -244,7 +244,10 @@ handleDraftCommitUtxo env directChain getCommitInfo body = do
         CannotCommit -> pure $ responseLBS status500 [] (Aeson.encode (FailedToDraftTxNotInitializing :: PostTxError tx))
  where
   deposit headId commitBlueprint = do
-    deadline <- addUTCTime (2 * toNominalDiffTime depositPeriod) <$> getCurrentTime
+    -- NOTE: Three times deposit period means we have one deposit period time to
+    -- increment because a deposit only activates after one deposit period and
+    -- expires one deposit period before deadline.
+    deadline <- addUTCTime (3 * toNominalDiffTime depositPeriod) <$> getCurrentTime
     draftDepositTx headId commitBlueprint deadline <&> \case
       Left e -> responseLBS status400 [] (Aeson.encode $ toJSON e)
       Right depositTx -> okJSON $ DraftCommitTxResponse depositTx

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

@@ -172,15 +172,22 @@ mkChain tracer queryTimeHandle wallet ctx LocalChainState{getLatest} submitTx =
     , draftDepositTx = \headId commitBlueprintTx deadline -> do
         let CommitBlueprintTx{lookupUTxO} = commitBlueprintTx
         ChainStateAt{spendableUTxO} <- atomically getLatest
-        timeHandle <- queryTimeHandle
+        TimeHandle{currentPointInTime} <- queryTimeHandle
         -- XXX: What an error handling mess
         runExceptT $ do
-          validBefore <- case currentPointInTime timeHandle of
-            -- XXX: We only need the current slot and this would never fail
+          (currentSlot, currentTime) <- case currentPointInTime of
             Left failureReason -> throwError FailedToConstructDepositTx{failureReason}
-            Right (s, _) -> pure $ s + fromInteger (truncate maxGraceTime)
+            Right (s, t) -> pure (s, t)
+          -- NOTE: Use a smaller upper bound than maxGraceTime to allow for
+          -- shorter than 200 slot deposit periods. This is only important on
+          -- fast moving networks (e.g. in testing). XXX: Making maxGraceTime
+          -- configurable would avoid this.
+          let untilDeadline = diffUTCTime deadline currentTime
+          let graceTime = maxGraceTime `min` untilDeadline / 2
+          -- -- NOTE: But also not make it smaller than 10 slots.
+          let validBeforeSlot = currentSlot + fromInteger (truncate graceTime `max` 10)
           lift . finalizeTx wallet ctx spendableUTxO lookupUTxO $
-            depositTx (networkId ctx) headId commitBlueprintTx validBefore deadline
+            depositTx (networkId ctx) headId commitBlueprintTx validBeforeSlot deadline
     , -- Submit a cardano transaction to the cardano-node using the
       -- LocalTxSubmission protocol.
       submitTx

hydra-tx/src/Hydra/Tx/ContestationPeriod.hs

@@ -22,14 +22,14 @@ instance Show ContestationPeriod where
 instance Enum ContestationPeriod where
   toEnum i
     | i > 0 = UnsafeContestationPeriod $ toEnum i
-    | otherwise = error $ "ContestationPeriod.toEnum: non-zero integer " <> toText (show i)
+    | otherwise = error $ "ContestationPeriod.toEnum: " <> toText (show i) <> " is not > 0"
 
   fromEnum (UnsafeContestationPeriod n) = fromEnum n
 
 instance Num ContestationPeriod where
   fromInteger i
     | i > 0 = UnsafeContestationPeriod $ fromInteger i
-    | otherwise = error $ "ContestationPeriod.fromInteger: non-zero integer " <> toText (show i)
+    | otherwise = error $ "ContestationPeriod.fromInteger: " <> toText (show i) <> " is not > 0"
 
   (+) (UnsafeContestationPeriod a) (UnsafeContestationPeriod b) = UnsafeContestationPeriod (a + b)
   (-) (UnsafeContestationPeriod a) (UnsafeContestationPeriod b) = UnsafeContestationPeriod (a - b)