Use contestation period as deposit deadline

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

@@ -751,7 +751,9 @@ canRecoverDeposit tracer workDir node hydraScriptsTxId =
     (`finally` returnFundsToFaucet tracer node Bob) $ do
       refuelIfNeeded tracer node Alice 30_000_000
       refuelIfNeeded tracer node Bob 30_000_000
-      let contestationPeriod = UnsafeContestationPeriod 1
+      -- NOTE: this value is also used to determine the deposit deadline
+      let deadline = 1
+      let contestationPeriod = UnsafeContestationPeriod deadline
       aliceChainConfig <-
         chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [Bob] contestationPeriod
           <&> setNetworkId networkId
@@ -800,6 +802,8 @@ canRecoverDeposit tracer workDir node hydraScriptsTxId =
 
         let path = BSC.unpack $ urlEncode False $ encodeUtf8 $ T.pack $ show (getTxId $ getTxBody tx)
 
+        threadDelay $ fromIntegral deadline
+
         recoverResp <-
           parseUrlThrow ("DELETE " <> hydraNodeBaseUrl n1 <> "/commits/" <> path)
             >>= httpJSON
@@ -825,7 +829,8 @@ 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
-      let contestationPeriod = UnsafeContestationPeriod 1
+      let deadline = 1
+      let contestationPeriod = UnsafeContestationPeriod deadline
       aliceChainConfig <-
         chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [Bob] contestationPeriod
           <&> setNetworkId networkId
@@ -880,6 +885,7 @@ canSeePendingDeposits tracer workDir node hydraScriptsTxId =
 
         forM_ deposited $ \deposit -> do
           let path = BSC.unpack $ urlEncode False $ encodeUtf8 $ T.pack $ show deposit
+          threadDelay $ fromIntegral deadline
           recoverResp <-
             parseUrlThrow ("DELETE " <> hydraNodeBaseUrl n1 <> "/commits/" <> path)
               >>= httpJSON

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

@@ -28,6 +28,8 @@ import Hydra.Tx (
   IsTx (..),
   UTxOType,
  )
+import Hydra.Tx.ContestationPeriod (toNominalDiffTime)
+import Hydra.Tx.Environment (Environment (..))
 import Network.HTTP.Types (status200, status400, status404, status500)
 import Network.Wai (
   Application,
@@ -129,6 +131,7 @@ httpApp ::
   IsChainState tx =>
   Tracer IO APIServerLog ->
   Chain tx IO ->
+  Environment ->
   PParams LedgerEra ->
   -- | A means to get commit info.
   IO CommitInfo ->
@@ -139,7 +142,7 @@ httpApp ::
   -- | Callback to yield a 'ClientInput' to the main event loop.
   (ClientInput tx -> IO ()) ->
   Application
-httpApp tracer directChain pparams getCommitInfo getConfirmedUTxO getPendingDeposits putClientInput request respond = do
+httpApp tracer directChain env pparams getCommitInfo getConfirmedUTxO getPendingDeposits putClientInput request respond = do
   traceWith tracer $
     APIHTTPRequestReceived
       { method = Method $ requestMethod request
@@ -155,7 +158,7 @@ httpApp tracer directChain pparams getCommitInfo getConfirmedUTxO getPendingDepo
         Just utxo -> respond $ okJSON utxo
     ("POST", ["commit"]) ->
       consumeRequestBodyStrict request
-        >>= handleDraftCommitUtxo directChain getCommitInfo
+        >>= handleDraftCommitUtxo env directChain getCommitInfo
         >>= respond
     ("DELETE", ["commits", _]) ->
       consumeRequestBodyStrict request
@@ -184,13 +187,14 @@ httpApp tracer directChain pparams getCommitInfo getConfirmedUTxO getPendingDepo
 handleDraftCommitUtxo ::
   forall tx.
   IsChainState tx =>
+  Environment ->
   Chain tx IO ->
   -- | A means to get commit info.
   IO CommitInfo ->
   -- | Request body.
   LBS.ByteString ->
   IO Response
-handleDraftCommitUtxo directChain getCommitInfo body = do
+handleDraftCommitUtxo env directChain getCommitInfo body = do
   case Aeson.eitherDecode' body :: Either String (DraftCommitTxRequest tx) of
     Left err ->
       pure $ responseLBS status400 [] (Aeson.encode $ Aeson.String $ pack err)
@@ -212,10 +216,7 @@ handleDraftCommitUtxo directChain getCommitInfo body = do
         CannotCommit -> pure $ responseLBS status500 [] (Aeson.encode (FailedToDraftTxNotInitializing :: PostTxError tx))
  where
   deposit headId commitBlueprint = do
-    -- TODO: How to make this configurable for testing? Right now this is just
-    -- set to current time in order to have easier time testing the recover.
-    -- Perhaps use contestation deadline to come up with a meaningful value?
-    deadline <- getCurrentTime
+    deadline <- addUTCTime (toNominalDiffTime contestationPeriod) <$> getCurrentTime
     draftDepositTx headId commitBlueprint deadline <&> \case
       Left e -> responseLBS status400 [] (Aeson.encode $ toJSON e)
       Right depositTx -> okJSON $ DraftCommitTxResponse depositTx
@@ -233,6 +234,7 @@ handleDraftCommitUtxo directChain getCommitInfo body = do
       Right commitTx ->
         okJSON $ DraftCommitTxResponse commitTx
   Chain{draftCommitTx, draftDepositTx} = directChain
+  Environment{contestationPeriod} = env
 
 -- | Handle request to recover a pending deposit.
 handleRecoverCommitUtxo ::

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

@@ -33,6 +33,7 @@ import Hydra.Logging (Tracer, traceWith)
 import Hydra.Network (IP, PortNumber)
 import Hydra.Persistence (PersistenceIncremental (..))
 import Hydra.Tx (Party)
+import Hydra.Tx.Environment (Environment)
 import Network.HTTP.Types (status500)
 import Network.Wai (responseLBS)
 import Network.Wai.Handler.Warp (
@@ -74,13 +75,14 @@ withAPIServer ::
   forall tx.
   IsChainState tx =>
   APIServerConfig ->
+  Environment ->
   Party ->
   PersistenceIncremental (TimedServerOutput tx) IO ->
   Tracer IO APIServerLog ->
   Chain tx IO ->
   PParams LedgerEra ->
   ServerComponent tx IO ()
-withAPIServer config party persistence tracer chain pparams callback action =
+withAPIServer config env party persistence tracer chain pparams callback action =
   handle onIOException $ do
     responseChannel <- newBroadcastTChanIO
     timedOutputEvents <- loadAll
@@ -112,7 +114,7 @@ withAPIServer config party persistence tracer chain pparams callback action =
             $ websocketsOr
               defaultConnectionOptions
               (wsApp party tracer history callback headStatusP headIdP snapshotUtxoP responseChannel)
-              (httpApp tracer chain pparams (atomically $ getLatest commitInfoP) (atomically $ getLatest snapshotUtxoP) (atomically $ getLatest pendingDepositsP) callback)
+              (httpApp tracer chain env pparams (atomically $ getLatest commitInfoP) (atomically $ getLatest snapshotUtxoP) (atomically $ getLatest pendingDepositsP) callback)
       )
       ( do
           waitForServerRunning

hydra-node/src/Hydra/Node/Run.hs

@@ -92,7 +92,7 @@ run opts = do
           -- API
           apiPersistence <- createPersistenceIncremental $ persistenceDir <> "/server-output"
           let apiServerConfig = APIServerConfig{host = apiHost, port = apiPort, tlsCertPath, tlsKeyPath}
-          withAPIServer apiServerConfig party apiPersistence (contramap APIServer tracer) chain pparams (wireClientInput wetHydraNode) $ \server -> do
+          withAPIServer apiServerConfig env party apiPersistence (contramap APIServer tracer) chain pparams (wireClientInput wetHydraNode) $ \server -> do
             -- Network
             let networkConfiguration = NetworkConfiguration{persistenceDir, signingKey, otherParties, host, port, peers, nodeId}
             withNetwork tracer networkConfiguration (wireNetworkInput wetHydraNode) $ \network -> do

hydra-node/test/Hydra/API/HTTPServerSpec.hs

@@ -29,6 +29,7 @@ import System.IO.Unsafe (unsafePerformIO)
 import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
 import Test.Hspec.Wai (MatchBody (..), ResponseMatcher (matchBody), get, post, shouldRespondWith, with)
 import Test.Hspec.Wai.Internal (withApplication)
+import Test.Hydra.Node.Fixture (testEnvironment)
 import Test.Hydra.Tx.Fixture (defaultPParams)
 import Test.Hydra.Tx.Gen (genTxOut)
 import Test.QuickCheck (
@@ -155,7 +156,7 @@ apiServerSpec = do
         putClientInput = const (pure ())
 
     describe "GET /protocol-parameters" $ do
-      with (return $ httpApp @SimpleTx nullTracer dummyChainHandle defaultPParams cantCommit getNothing getPendingDeposits putClientInput) $ do
+      with (return $ httpApp @SimpleTx nullTracer dummyChainHandle testEnvironment defaultPParams cantCommit getNothing getPendingDeposits putClientInput) $ do
         it "matches schema" $
           withJsonSpecifications $ \schemaDir -> do
             get "/protocol-parameters"
@@ -174,7 +175,7 @@ apiServerSpec = do
     describe "GET /snapshot/utxo" $ do
       prop "responds correctly" $ \utxo -> do
         let getUTxO = pure utxo
-        withApplication (httpApp @SimpleTx nullTracer dummyChainHandle defaultPParams cantCommit getUTxO getPendingDeposits putClientInput) $ do
+        withApplication (httpApp @SimpleTx nullTracer dummyChainHandle testEnvironment defaultPParams cantCommit getUTxO getPendingDeposits putClientInput) $ do
           get "/snapshot/utxo"
             `shouldRespondWith` case utxo of
               Nothing -> 404
@@ -187,7 +188,7 @@ apiServerSpec = do
           . withJsonSpecifications
           $ \schemaDir -> do
             let getUTxO = pure $ Just utxo
-            withApplication (httpApp @Tx nullTracer dummyChainHandle defaultPParams cantCommit getUTxO getPendingDeposits putClientInput) $ do
+            withApplication (httpApp @Tx nullTracer dummyChainHandle testEnvironment defaultPParams cantCommit getUTxO getPendingDeposits putClientInput) $ do
               get "/snapshot/utxo"
                 `shouldRespondWith` 200
                   { matchBody =
@@ -200,7 +201,7 @@ apiServerSpec = do
         forAll genTxOut $ \o -> do
           let o' = modifyTxOutDatum (const $ mkTxOutDatumInline (123 :: Integer)) o
           let getUTxO = pure $ Just $ UTxO.fromPairs [(i, o')]
-          withApplication (httpApp @Tx nullTracer dummyChainHandle defaultPParams cantCommit getUTxO getPendingDeposits putClientInput) $ do
+          withApplication (httpApp @Tx nullTracer dummyChainHandle testEnvironment defaultPParams cantCommit getUTxO getPendingDeposits putClientInput) $ do
             get "/snapshot/utxo"
               `shouldRespondWith` 200
                 { matchBody = MatchBody $ \_ body ->
@@ -218,7 +219,7 @@ apiServerSpec = do
                   pure $ Right tx
               }
       prop "responds on valid requests" $ \(request :: DraftCommitTxRequest Tx) ->
-        withApplication (httpApp nullTracer workingChainHandle defaultPParams getHeadId getNothing getPendingDeposits putClientInput) $ do
+        withApplication (httpApp nullTracer workingChainHandle testEnvironment defaultPParams getHeadId getNothing getPendingDeposits putClientInput) $ do
           post "/commit" (Aeson.encode request)
             `shouldRespondWith` 200
 
@@ -242,7 +243,7 @@ apiServerSpec = do
               _ -> property
         checkCoverage $
           coverage $
-            withApplication (httpApp @Tx nullTracer (failingChainHandle postTxError) defaultPParams getHeadId getNothing getPendingDeposits putClientInput) $ do
+            withApplication (httpApp @Tx nullTracer (failingChainHandle postTxError) testEnvironment defaultPParams getHeadId getNothing getPendingDeposits putClientInput) $ do
               post "/commit" (Aeson.encode (request :: DraftCommitTxRequest Tx))
                 `shouldRespondWith` expectedResponse
 

hydra-node/test/Hydra/API/ServerSpec.hs

@@ -44,7 +44,7 @@ import Network.Simple.WSS qualified as WSS
 import Network.TLS (ClientHooks (onServerCertificate), ClientParams (clientHooks), defaultParamsClient)
 import Network.WebSockets (Connection, ConnectionException, receiveData, runClient, sendBinaryData)
 import System.IO.Error (isAlreadyInUseError)
-import Test.Hydra.Tx.Fixture (alice, defaultPParams, testHeadId)
+import Test.Hydra.Tx.Fixture (alice, defaultPParams, testEnvironment, testHeadId)
 import Test.Hydra.Tx.Gen ()
 import Test.Network.Ports (withFreePort)
 import Test.QuickCheck (checkCoverage, cover, generate)
@@ -320,7 +320,7 @@ spec =
                     , tlsCertPath = Just "test/tls/certificate.pem"
                     , tlsKeyPath = Just "test/tls/key.pem"
                     }
-            withAPIServer @SimpleTx config alice mockPersistence tracer dummyChainHandle defaultPParams noop $ \_ -> do
+            withAPIServer @SimpleTx config testEnvironment alice mockPersistence tracer dummyChainHandle defaultPParams noop $ \_ -> do
               let clientParams = defaultParamsClient "127.0.0.1" ""
                   allowAnyParams =
                     clientParams{clientHooks = (clientHooks clientParams){onServerCertificate = \_ _ _ _ -> pure []}}
@@ -388,7 +388,7 @@ withTestAPIServer ::
   (Server SimpleTx IO -> IO ()) ->
   IO ()
 withTestAPIServer port actor persistence tracer action = do
-  withAPIServer @SimpleTx config actor persistence tracer dummyChainHandle defaultPParams noop action
+  withAPIServer @SimpleTx config testEnvironment actor persistence tracer dummyChainHandle defaultPParams noop action
  where
   config = APIServerConfig{host = "127.0.0.1", port, tlsCertPath = Nothing, tlsKeyPath = Nothing}