diff --git a/CHANGELOG.md b/CHANGELOG.md index 19e0315041e..186a52c9cdc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -52,6 +52,11 @@ changes. - Fixed TUI key bindings for exiting in dialogs. +- Prevent users from resuming a Hydra node after changing its configurations. +Ensure that the node terminates when attempting to start a Hydra node with a +number of configured peers that doesn't match the persisted state (i.e., the +number of parties in the /acks vector). + ## [0.13.0] - 2023-10-03 - **BREAKING** Update to plutus 1.9. This changes the script hashes. diff --git a/hydra-cluster/bench/Bench/EndToEnd.hs b/hydra-cluster/bench/Bench/EndToEnd.hs index 25d39ceb08f..3356734e1f9 100644 --- a/hydra-cluster/bench/Bench/EndToEnd.hs +++ b/hydra-cluster/bench/Bench/EndToEnd.hs @@ -94,7 +94,7 @@ bench startingNodeId timeoutSeconds workDir dataset@Dataset{clientDatasets, titl let contestationPeriod = UnsafeContestationPeriod 10 withHydraCluster hydraTracer workDir nodeSocket startingNodeId cardanoKeys hydraKeys hydraScriptsTxId contestationPeriod $ \(leader :| followers) -> do let clients = leader : followers - waitForNodesConnected hydraTracer clients + waitForNodesConnected hydraTracer 20 clients putTextLn "Initializing Head" send leader $ input "Init" [] diff --git a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs index ccca0ae5377..6fa2ba71742 100644 --- a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs +++ b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs @@ -4,7 +4,7 @@ module Hydra.Cluster.Scenarios where import Hydra.Prelude -import Test.Hydra.Prelude (failure) +import Test.Hydra.Prelude (HUnitFailure, anyException, failure) import Cardano.Api.UTxO qualified as UTxO import CardanoClient ( @@ -96,7 +96,9 @@ import Network.HTTP.Req ( (/:), ) import PlutusLedgerApi.Test.Examples qualified as Plutus -import Test.Hspec.Expectations (shouldBe, shouldReturn, shouldThrow) +import System.Directory (removeDirectoryRecursive) +import System.FilePath (()) +import Test.Hspec.Expectations (Selector, shouldBe, shouldReturn, shouldThrow) import Test.QuickCheck (generate) data EndToEndLog @@ -147,6 +149,50 @@ restartedNodeCanObserveCommitTx tracer workDir cardanoNode hydraScriptsTxId = do where RunningNode{nodeSocket, networkId} = cardanoNode +testPreventResumeReconfiguredPeer :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> TxId -> IO () +testPreventResumeReconfiguredPeer tracer workDir cardanoNode hydraScriptsTxId = do + let contestationPeriod = UnsafeContestationPeriod 1 + aliceChainConfig <- + chainConfigFor Alice workDir nodeSocket [Bob] contestationPeriod + <&> \config -> (config :: ChainConfig){networkId} + + aliceChainConfigWithoutBob <- + chainConfigFor Alice workDir nodeSocket [] contestationPeriod + <&> \config -> (config :: ChainConfig){networkId} + + bobChainConfig <- + chainConfigFor Bob workDir nodeSocket [Alice] contestationPeriod + <&> \config -> (config :: ChainConfig){networkId} + + let hydraTracer = contramap FromHydraNode tracer + aliceStartsWithoutKnowingBob = + withHydraNode hydraTracer aliceChainConfigWithoutBob workDir 2 aliceSk [] [1, 2] hydraScriptsTxId + aliceRestartsWithBobConfigured = + withHydraNode hydraTracer aliceChainConfig workDir 2 aliceSk [bobVk] [1, 2] hydraScriptsTxId + + withHydraNode hydraTracer bobChainConfig workDir 1 bobSk [aliceVk] [1, 2] hydraScriptsTxId $ \n1 -> do + aliceStartsWithoutKnowingBob $ \n2 -> do + failToConnect hydraTracer [n1, n2] + + threadDelay 1 + + aliceRestartsWithBobConfigured (const $ threadDelay 1) + `shouldThrow` aFailure + + threadDelay 1 + + removeDirectoryRecursive $ workDir "state-2" + + aliceRestartsWithBobConfigured $ \n2 -> do + waitForNodesConnected hydraTracer 10 [n1, n2] + where + RunningNode{nodeSocket, networkId} = cardanoNode + + aFailure :: Selector HUnitFailure + aFailure = const True + + failToConnect tr nodes = waitForNodesConnected tr 10 nodes `shouldThrow` anyException + restartedNodeCanAbort :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> TxId -> IO () restartedNodeCanAbort tracer workDir cardanoNode hydraScriptsTxId = do refuelIfNeeded tracer cardanoNode Alice 100_000_000 @@ -517,7 +563,7 @@ threeNodesNoErrorsOnOpen tracer tmpDir node@RunningNode{nodeSocket} hydraScripts let hydraTracer = contramap FromHydraNode tracer withHydraCluster hydraTracer tmpDir nodeSocket 0 cardanoKeys hydraKeys hydraScriptsTxId contestationPeriod $ \(leader :| rest) -> do let clients = leader : rest - waitForNodesConnected hydraTracer clients + waitForNodesConnected hydraTracer 20 clients -- Funds to be used as fuel by Hydra protocol transactions seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) diff --git a/hydra-cluster/src/HydraNode.hs b/hydra-cluster/src/HydraNode.hs index 61f67cb657d..e52b28f8443 100644 --- a/hydra-cluster/src/HydraNode.hs +++ b/hydra-cluster/src/HydraNode.hs @@ -218,8 +218,8 @@ withHydraCluster :: ContestationPeriod -> (NonEmpty HydraClient -> IO a) -> IO a -withHydraCluster tracer workDir nodeSocket firstNodeId allKeys hydraKeys hydraScriptsTxId contestationPeriod action = - withConfiguredHydraCluster tracer workDir nodeSocket firstNodeId allKeys hydraKeys hydraScriptsTxId (const $ id) contestationPeriod action +withHydraCluster tracer workDir nodeSocket firstNodeId allKeys hydraKeys hydraScriptsTxId = + withConfiguredHydraCluster tracer workDir nodeSocket firstNodeId allKeys hydraKeys hydraScriptsTxId (const id) withConfiguredHydraCluster :: HasCallStack => @@ -298,14 +298,11 @@ withHydraNode :: withHydraNode tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds hydraScriptsTxId action = do withLogFile logFilePath $ \logFileHandle -> do withHydraNode' chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds hydraScriptsTxId (Just logFileHandle) $ do - \_ _err processHandle -> do - result <- - race - (checkProcessHasNotDied ("hydra-node (" <> show hydraNodeId <> ")") processHandle) - (withConnectionToNode tracer hydraNodeId action) - case result of - Left e -> absurd e - Right a -> pure a + \_ processHandle -> do + race + (checkProcessHasNotDied ("hydra-node (" <> show hydraNodeId <> ")") processHandle) + (withConnectionToNode tracer hydraNodeId action) + <&> either absurd id where logFilePath = workDir "logs" "hydra-node-" <> show hydraNodeId <.> "log" @@ -322,7 +319,7 @@ withHydraNode' :: TxId -> -- | If given use this as std out. Maybe Handle -> - (Handle -> Handle -> ProcessHandle -> IO a) -> + (Handle -> ProcessHandle -> IO a) -> IO a withHydraNode' chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds hydraScriptsTxId mGivenStdOut action = do withSystemTempDirectory "hydra-node" $ \dir -> do @@ -357,12 +354,12 @@ withHydraNode' chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds h } ) { std_out = maybe CreatePipe UseHandle mGivenStdOut - , std_err = CreatePipe + , std_err = Inherit } withCreateProcess p $ \_stdin mCreatedHandle mErr processHandle -> case (mCreatedHandle, mGivenStdOut, mErr) of - (Just out, _, Just err) -> action out err processHandle - (Nothing, Just out, Just err) -> action out err processHandle + (Just out, _, _) -> action out processHandle + (Nothing, Just out, _) -> action out processHandle (_, _, _) -> error "Should not happen™" where peers = @@ -377,13 +374,15 @@ withHydraNode' chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds h withConnectionToNode :: Tracer IO HydraNodeLog -> Int -> (HydraClient -> IO a) -> IO a withConnectionToNode tracer hydraNodeId action = do connectedOnce <- newIORef False - tryConnect connectedOnce + tryConnect connectedOnce (200 :: Int) where - tryConnect connectedOnce = - doConnect connectedOnce `catch` \(e :: IOException) -> do - readIORef connectedOnce >>= \case - False -> threadDelay 0.1 >> tryConnect connectedOnce - True -> throwIO e + tryConnect connectedOnce n + | n == 0 = failure $ "Timed out waiting for connection to hydra-node " <> show hydraNodeId + | otherwise = + doConnect connectedOnce `catch` \(e :: IOException) -> do + readIORef connectedOnce >>= \case + False -> threadDelay 0.1 >> tryConnect connectedOnce (n - 1) + True -> throwIO e doConnect connectedOnce = runClient "127.0.0.1" (4_000 + hydraNodeId) "/" $ \connection -> do atomicWriteIORef connectedOnce True @@ -395,13 +394,13 @@ withConnectionToNode tracer hydraNodeId action = do hydraNodeProcess :: RunOptions -> CreateProcess hydraNodeProcess = proc "hydra-node" . toArgs -waitForNodesConnected :: HasCallStack => Tracer IO HydraNodeLog -> [HydraClient] -> IO () -waitForNodesConnected tracer clients = +waitForNodesConnected :: HasCallStack => Tracer IO HydraNodeLog -> DiffTime -> [HydraClient] -> IO () +waitForNodesConnected tracer timeOut clients = mapM_ waitForNodeConnected clients where allNodeIds = hydraNodeId <$> clients waitForNodeConnected n@HydraClient{hydraNodeId} = - waitForAll tracer (fromIntegral $ 20 * length allNodeIds) [n] $ + waitForAll tracer timeOut [n] $ fmap ( \nodeId -> object diff --git a/hydra-cluster/test/Test/CardanoClientSpec.hs b/hydra-cluster/test/Test/CardanoClientSpec.hs index 3431b6dc5e4..740752a1186 100644 --- a/hydra-cluster/test/Test/CardanoClientSpec.hs +++ b/hydra-cluster/test/Test/CardanoClientSpec.hs @@ -15,7 +15,7 @@ import Test.EndToEndSpec (withClusterTempDir) spec :: Spec spec = - around showLogsOnFailure $ + around (showLogsOnFailure "CardanoClientSpec") $ it "queryGenesisParameters works as expected" $ \tracer -> failAfter 60 $ withClusterTempDir "queryGenesisParameters" $ \tmpDir -> do diff --git a/hydra-cluster/test/Test/CardanoNodeSpec.hs b/hydra-cluster/test/Test/CardanoNodeSpec.hs index 9a47dc1e01a..c284cfd4bab 100644 --- a/hydra-cluster/test/Test/CardanoNodeSpec.hs +++ b/hydra-cluster/test/Test/CardanoNodeSpec.hs @@ -26,7 +26,7 @@ spec = do -- genesis-shelley.json it "withCardanoNodeDevnet does start a block-producing devnet within 5 seconds" $ failAfter 5 $ - showLogsOnFailure $ \tr -> do + showLogsOnFailure "CardanoNodeSpec" $ \tr -> do withTempDir "hydra-cluster" $ \tmp -> do withCardanoNodeDevnet tr tmp $ \RunningNode{nodeSocket, networkId} -> do doesFileExist (unFile nodeSocket) `shouldReturn` True diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index 104778d6643..a8a6eb02e73 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -31,7 +31,7 @@ spec :: Spec spec = do it "can observe hydra transactions created by hydra-nodes" $ failAfter 60 $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "ChainObserverSpec" $ \tracer -> do withTempDir "hydra-chain-observer" $ \tmpDir -> do -- Start a cardano devnet withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do diff --git a/hydra-cluster/test/Test/DirectChainSpec.hs b/hydra-cluster/test/Test/DirectChainSpec.hs index 1a8d86fbd32..8254898582f 100644 --- a/hydra-cluster/test/Test/DirectChainSpec.hs +++ b/hydra-cluster/test/Test/DirectChainSpec.hs @@ -81,7 +81,7 @@ import System.Process (proc, readCreateProcess) import Test.QuickCheck (generate) spec :: Spec -spec = around showLogsOnFailure $ do +spec = around (showLogsOnFailure "DirectChainSpec") $ do it "can init and abort a head given nothing has been committed" $ \tracer -> do withTempDir "hydra-cluster" $ \tmp -> do withCardanoNodeDevnet (contramap FromNode tracer) tmp $ \node@RunningNode{nodeSocket} -> do diff --git a/hydra-cluster/test/Test/EndToEndSpec.hs b/hydra-cluster/test/Test/EndToEndSpec.hs index 0f1646d88b7..175fec9e6b8 100644 --- a/hydra-cluster/test/Test/EndToEndSpec.hs +++ b/hydra-cluster/test/Test/EndToEndSpec.hs @@ -67,6 +67,7 @@ import Hydra.Cluster.Scenarios ( singlePartyCommitsExternalScriptWithInlineDatum, singlePartyCommitsFromExternalScript, singlePartyHeadFullLifeCycle, + testPreventResumeReconfiguredPeer, threeNodesNoErrorsOnOpen, ) import Hydra.Cluster.Util (chainConfigFor, keysFor) @@ -111,7 +112,7 @@ withClusterTempDir name = withTempDir ("hydra-cluster-e2e-" <> name) spec :: Spec -spec = around showLogsOnFailure $ +spec = around (showLogsOnFailure "EndToEndSpec") $ describe "End-to-end on Cardano devnet" $ do describe "single party hydra head" $ do it "full head life-cycle" $ \tracer -> do @@ -184,7 +185,7 @@ spec = around showLogsOnFailure $ let hydraTracer = contramap FromHydraNode tracer withHydraCluster hydraTracer tmpDir nodeSocket firstNodeId cardanoKeys hydraKeys hydraScriptsTxId contestationPeriod $ \nodes -> do let [n1, n2, n3] = toList nodes - waitForNodesConnected hydraTracer [n1, n2, n3] + waitForNodesConnected hydraTracer 20 [n1, n2, n3] -- Funds to be used as fuel by Hydra protocol transactions seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) @@ -241,6 +242,12 @@ spec = around showLogsOnFailure $ publishHydraScriptsAs node Faucet >>= restartedNodeCanObserveCommitTx tracer tmpDir node + it "prevent resuming a head after reconfiguring a peer" $ \tracer -> do + withClusterTempDir "prevent-resume-reconfiguring-peer" $ \tmpDir -> do + withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \node -> + publishHydraScriptsAs node Faucet + >>= testPreventResumeReconfiguredPeer tracer tmpDir node + it "can start chain from the past and replay on-chain events" $ \tracer -> withClusterTempDir "replay-chain-events" $ \tmp -> withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmp $ \node@RunningNode{nodeSocket, networkId} -> do @@ -300,7 +307,7 @@ spec = around showLogsOnFailure $ withAliceNode $ \n1 -> do headId <- withBobNode $ \n2 -> do - waitForNodesConnected hydraTracer [n1, n2] + waitForNodesConnected hydraTracer 20 [n1, n2] send n1 $ input "Init" [] headId <- waitForAllMatch 10 [n1, n2] $ headIsInitializingWith (Set.fromList [alice, bob]) @@ -420,7 +427,7 @@ spec = around showLogsOnFailure $ withHydraNode hydraTracer carolChainConfig tmpDir 3 carolSk [aliceVk, bobVk] allNodeIds hydraScriptsTxId $ \n3 -> do -- Funds to be used as fuel by Hydra protocol transactions seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) - waitForNodesConnected hydraTracer [n1, n2, n3] + waitForNodesConnected hydraTracer 20 [n1, n2, n3] send n1 $ input "Init" [] void $ waitForAllMatch 3 [n1] $ headIsInitializingWith (Set.fromList [alice, bob, carol]) metrics <- getMetrics n1 @@ -432,7 +439,7 @@ spec = around showLogsOnFailure $ withCardanoNodeDevnet (contramap FromCardanoNode tracer) dir $ \node@RunningNode{nodeSocket} -> do chainConfig <- chainConfigFor Alice dir nodeSocket [] (UnsafeContestationPeriod 1) hydraScriptsTxId <- publishHydraScriptsAs node Faucet - withHydraNode' chainConfig dir 1 aliceSk [] [1] hydraScriptsTxId Nothing $ \stdOut _stdErr _processHandle -> do + withHydraNode' chainConfig dir 1 aliceSk [] [1] hydraScriptsTxId Nothing $ \stdOut _processHandle -> do waitForLog 10 stdOut "JSON object with key NodeOptions" $ \line -> line ^? key "message" . key "tag" == Just (Aeson.String "NodeOptions") @@ -492,7 +499,7 @@ timedTx tmpDir tracer node@RunningNode{networkId, nodeSocket} hydraScriptsTxId = aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket [] contestationPeriod let hydraTracer = contramap FromHydraNode tracer withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] hydraScriptsTxId $ \n1 -> do - waitForNodesConnected hydraTracer [n1] + waitForNodesConnected hydraTracer 20 [n1] let lovelaceBalanceValue = 100_000_000 -- Funds to be used as fuel by Hydra protocol transactions @@ -563,7 +570,7 @@ initAndClose tmpDir tracer clusterIx hydraScriptsTxId node@RunningNode{nodeSocke let hydraTracer = contramap FromHydraNode tracer withHydraCluster hydraTracer tmpDir nodeSocket firstNodeId cardanoKeys hydraKeys hydraScriptsTxId contestationPeriod $ \nodes -> do let [n1, n2, n3] = toList nodes - waitForNodesConnected hydraTracer [n1, n2, n3] + waitForNodesConnected hydraTracer 20 [n1, n2, n3] -- Funds to be used as fuel by Hydra protocol transactions seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) diff --git a/hydra-cluster/test/Test/Hydra/Cluster/FaucetSpec.hs b/hydra-cluster/test/Test/Hydra/Cluster/FaucetSpec.hs index 5a2f450d90c..048c74f81ce 100644 --- a/hydra-cluster/test/Test/Hydra/Cluster/FaucetSpec.hs +++ b/hydra-cluster/test/Test/Hydra/Cluster/FaucetSpec.hs @@ -19,7 +19,7 @@ spec :: Spec spec = do describe "seedFromFaucet" $ it "should work concurrently" $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "FaucetSpec" $ \tracer -> failAfter 30 $ withTempDir "end-to-end-cardano-node" $ \tmpDir -> withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \node -> @@ -29,7 +29,7 @@ spec = do describe "returnFundsToFaucet" $ it "seedFromFaucet and returnFundsToFaucet work together" $ do - showLogsOnFailure $ \tracer -> + showLogsOnFailure "FaucetSpec" $ \tracer -> withTempDir "end-to-end-cardano-node" $ \tmpDir -> withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \node@RunningNode{networkId, nodeSocket} -> do let faucetTracer = contramap FromFaucet tracer diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal index 4d9cf76f009..18d2a170dee 100644 --- a/hydra-node/hydra-node.cabal +++ b/hydra-node/hydra-node.cabal @@ -95,6 +95,7 @@ library Hydra.Node Hydra.Node.EventQueue Hydra.Node.Network + Hydra.Node.ParameterMismatch Hydra.Options Hydra.Party Hydra.Persistence diff --git a/hydra-node/json-schemas/logs.yaml b/hydra-node/json-schemas/logs.yaml index 46cad7ba7ae..54866e2fa67 100644 --- a/hydra-node/json-schemas/logs.yaml +++ b/hydra-node/json-schemas/logs.yaml @@ -720,6 +720,22 @@ definitions: "$ref": "api.yaml#/components/schemas/Party" description: >- Parties configured as the node argument. + - title: SavedNetworkPartiesInconsistent + description: >- + The configured peer list does not match with the value from the loaded state. + type: object + additionalProperties: false + required: + - tag + - numberOfParties + properties: + tag: + type: string + enum: ["SavedNetworkPartiesInconsistent"] + numberOfParties: + type: number + description: >- + Number of parties configured as the node argument. # TODO: Fill the gap! Network: {} diff --git a/hydra-node/src/Hydra/Logging.hs b/hydra-node/src/Hydra/Logging.hs index 97eed7fc200..08c5f31af47 100644 --- a/hydra-node/src/Hydra/Logging.hs +++ b/hydra-node/src/Hydra/Logging.hs @@ -128,19 +128,21 @@ withTracerOutputTo hdl namespace action = do -- metadata. showLogsOnFailure :: (MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m, ToJSON msg) => + Text -> (Tracer m msg -> m a) -> m a -showLogsOnFailure action = do +showLogsOnFailure namespace action = do tvar <- newTVarIO [] - action (traceInTVar tvar) + action (traceInTVar tvar namespace) `onException` (readTVarIO tvar >>= mapM_ (say . decodeUtf8 . Aeson.encode) . reverse) traceInTVar :: (MonadFork m, MonadTime m, MonadSTM m) => TVar m [Envelope msg] -> + Text -> Tracer m msg -traceInTVar tvar = Tracer $ \msg -> do - envelope <- mkEnvelope "" msg +traceInTVar tvar namespace = Tracer $ \msg -> do + envelope <- mkEnvelope namespace msg atomically $ modifyTVar tvar (envelope :) -- * Internal functions diff --git a/hydra-node/src/Hydra/Node.hs b/hydra-node/src/Hydra/Node.hs index 64425bed482..bd43cae6d28 100644 --- a/hydra-node/src/Hydra/Node.hs +++ b/hydra-node/src/Hydra/Node.hs @@ -28,7 +28,6 @@ import Hydra.Chain ( PostTxError, ) import Hydra.Chain.Direct.Util (readFileTextEnvelopeThrow) -import Hydra.ContestationPeriod (ContestationPeriod) import Hydra.Crypto (AsType (AsHydraKey)) import Hydra.HeadLogic ( Effect (..), @@ -52,6 +51,7 @@ import Hydra.Logging (Tracer, traceWith) import Hydra.Network (Network (..)) import Hydra.Network.Message (Message) import Hydra.Node.EventQueue (EventQueue (..), Queued (..)) +import Hydra.Node.ParameterMismatch (ParamMismatch (..), ParameterMismatch (..)) import Hydra.Options (ChainConfig (..), RunOptions (..)) import Hydra.Party (Party (..), deriveParty) import Hydra.Persistence (PersistenceIncremental (..), loadAll) @@ -74,21 +74,6 @@ initEnvironment RunOptions{hydraSigningKey, hydraVerificationKeys, chainConfig = loadParty p = Party <$> readFileTextEnvelopeThrow (AsVerificationKey AsHydraKey) p --- | Exception used to indicate command line options not matching the persisted --- state. -newtype ParameterMismatch = ParameterMismatch [ParamMismatch] - deriving stock (Eq, Show) - deriving anyclass (Exception) - -data ParamMismatch - = ContestationPeriodMismatch {loadedCp :: ContestationPeriod, configuredCp :: ContestationPeriod} - | PartiesMismatch {loadedParties :: [Party], configuredParties :: [Party]} - deriving stock (Generic, Eq, Show) - deriving anyclass (ToJSON, FromJSON) - -instance Arbitrary ParamMismatch where - arbitrary = genericArbitrary - -- | Checks that command line options match a given 'HeadState'. This funciton -- takes 'Environment' because it is derived from 'RunOptions' via -- 'initEnvironment'. diff --git a/hydra-node/src/Hydra/Node/Network.hs b/hydra-node/src/Hydra/Node/Network.hs index 037454f463e..d6c0d4776bc 100644 --- a/hydra-node/src/Hydra/Node/Network.hs +++ b/hydra-node/src/Hydra/Node/Network.hs @@ -65,20 +65,26 @@ module Hydra.Node.Network ( NetworkConfiguration (..), withNetwork, withFlipHeartbeats, + configureMessagePersistence, + acksFile, ) where import Hydra.Prelude hiding (fromList, replicate) import Control.Tracer (Tracer) import Hydra.Crypto (HydraKey, SigningKey) +import Hydra.Logging (traceWith) import Hydra.Logging.Messages (HydraLog (..)) import Hydra.Network (Host (..), IP, NetworkComponent, NodeId, PortNumber) import Hydra.Network.Authenticate (Authenticated (Authenticated), Signed, withAuthentication) import Hydra.Network.Heartbeat (ConnectionMessages, Heartbeat (..), withHeartbeat) import Hydra.Network.Ouroboros (TraceOuroborosNetwork, WithHost, withOuroborosNetwork) -import Hydra.Network.Reliability (ReliableMsg, mkMessagePersistence, withReliability) +import Hydra.Network.Reliability (MessagePersistence, ReliableMsg, mkMessagePersistence, withReliability) +import Hydra.Node (HydraNodeLog (..)) +import Hydra.Node.ParameterMismatch (ParamMismatch (..), ParameterMismatch (..)) import Hydra.Party (Party, deriveParty) -import Hydra.Persistence (createPersistence, createPersistenceIncremental) +import Hydra.Persistence (Persistence (..), createPersistence, createPersistenceIncremental) +import System.FilePath (()) -- | An alias for logging messages output by network component. -- The type is made complicated because the various subsystems use part of the tracer only. @@ -117,10 +123,9 @@ withNetwork tracer connectionMessages configuration callback action = do let localhost = Host{hostname = show host, port} me = deriveParty signingKey numberOfParties = length $ me : otherParties - msgPersistence <- createPersistenceIncremental $ persistenceDir <> "/network-messages" - ackPersistence <- createPersistence $ persistenceDir <> "/acks" - let messagePersistence = mkMessagePersistence numberOfParties msgPersistence ackPersistence - reliability = + messagePersistence <- configureMessagePersistence (contramap Node tracer) persistenceDir numberOfParties + + let reliability = withFlipHeartbeats $ withReliability (contramap Reliability tracer) messagePersistence me otherParties $ withAuthentication (contramap Authentication tracer) signingKey otherParties $ @@ -131,6 +136,30 @@ withNetwork tracer connectionMessages configuration callback action = do where NetworkConfiguration{persistenceDir, signingKey, otherParties, host, port, peers, nodeId} = configuration +-- | Create `MessagePersistence` handle to be used by `Reliability` network layer. +-- +-- This function will `throw` a `ParameterMismatch` exception if: +-- +-- * Some state already exists and is loaded, +-- * The number of parties is not the same as the number of acknowledgments saved. +configureMessagePersistence :: + (MonadIO m, MonadThrow m, FromJSON msg, ToJSON msg) => + Tracer m (HydraNodeLog tx) -> + FilePath -> + Int -> + m (MessagePersistence m msg) +configureMessagePersistence tracer persistenceDir numberOfParties = do + msgPersistence <- createPersistenceIncremental $ storedMessagesFile persistenceDir + ackPersistence@Persistence{load} <- createPersistence $ acksFile persistenceDir + mAcks <- load + ackPersistence' <- case fmap (\acks -> length acks == numberOfParties) mAcks of + Just False -> do + let paramsMismatch = [SavedNetworkPartiesInconsistent{numberOfParties}] + traceWith tracer (Misconfiguration paramsMismatch) + throwIO $ ParameterMismatch paramsMismatch + _ -> pure ackPersistence + pure $ mkMessagePersistence numberOfParties msgPersistence ackPersistence' + withFlipHeartbeats :: NetworkComponent m (Authenticated (Heartbeat msg)) msg1 a -> NetworkComponent m (Heartbeat (Authenticated msg)) msg1 a @@ -140,3 +169,11 @@ withFlipHeartbeats withBaseNetwork callback = unwrapHeartbeats = \case Authenticated (Data nid msg) party -> callback $ Data nid (Authenticated msg party) Authenticated (Ping nid) _ -> callback $ Ping nid + +-- | Where are the messages stored, relative to given directory. +storedMessagesFile :: FilePath -> FilePath +storedMessagesFile = ( "network-messages") + +-- | Where is the acknowledgments vector stored, relative to given directory. +acksFile :: FilePath -> FilePath +acksFile = ( "acks") diff --git a/hydra-node/src/Hydra/Node/ParameterMismatch.hs b/hydra-node/src/Hydra/Node/ParameterMismatch.hs new file mode 100644 index 00000000000..0a7bcc0e41f --- /dev/null +++ b/hydra-node/src/Hydra/Node/ParameterMismatch.hs @@ -0,0 +1,26 @@ +-- | Structured errors related to configuration mismatch. +-- +-- When we start a `Hydra.Node` we need to do sanity checks between what's +-- provided as parameters to the node and what's persisted. +module Hydra.Node.ParameterMismatch where + +import Hydra.Prelude + +import Hydra.ContestationPeriod (ContestationPeriod) +import Hydra.Party (Party) + +-- | Exception used to indicate command line options not matching the persisted +-- state. +newtype ParameterMismatch = ParameterMismatch [ParamMismatch] + deriving stock (Eq, Show) + deriving anyclass (Exception) + +data ParamMismatch + = ContestationPeriodMismatch {loadedCp :: ContestationPeriod, configuredCp :: ContestationPeriod} + | PartiesMismatch {loadedParties :: [Party], configuredParties :: [Party]} + | SavedNetworkPartiesInconsistent {numberOfParties :: Int} + deriving stock (Generic, Eq, Show) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary ParamMismatch where + arbitrary = genericArbitrary diff --git a/hydra-node/test/Hydra/API/ServerSpec.hs b/hydra-node/test/Hydra/API/ServerSpec.hs index cd97760a27f..bf19f9f343d 100644 --- a/hydra-node/test/Hydra/API/ServerSpec.hs +++ b/hydra-node/test/Hydra/API/ServerSpec.hs @@ -58,7 +58,7 @@ spec :: Spec spec = describe "ServerSpec" $ parallel $ do it "should fail on port in use" $ do - showLogsOnFailure $ \tracer -> failAfter 5 $ do + showLogsOnFailure "ServerSpec" $ \tracer -> failAfter 5 $ do let withServerOnPort p = withTestAPIServer p alice mockPersistence tracer withFreePort $ \port -> do -- We should not be able to start the server on the same port twice @@ -70,7 +70,7 @@ spec = describe "ServerSpec" $ it "greets" $ do failAfter 5 $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withFreePort $ \port -> withTestAPIServer port alice mockPersistence tracer $ \_ -> do withClient port "/" $ \conn -> do @@ -78,7 +78,7 @@ spec = describe "ServerSpec" $ it "Greetings should contain the hydra-node version" $ do failAfter 5 $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withFreePort $ \port -> withTestAPIServer port alice mockPersistence tracer $ \_ -> do withClient port "/" $ \conn -> do @@ -89,7 +89,7 @@ spec = describe "ServerSpec" $ it "sends sendOutput to all connected clients" $ do queue <- atomically newTQueue - showLogsOnFailure $ \tracer -> failAfter 5 $ + showLogsOnFailure "ServerSpec" $ \tracer -> failAfter 5 $ withFreePort $ \port -> do withTestAPIServer port alice mockPersistence tracer $ \Server{sendOutput} -> do semaphore <- newTVarIO 0 @@ -110,7 +110,7 @@ spec = describe "ServerSpec" $ failAfter 1 $ atomically (tryReadTQueue queue) `shouldReturn` Nothing it "sends all sendOutput history to all connected clients after a restart" $ do - showLogsOnFailure $ \tracer -> failAfter 5 $ + showLogsOnFailure "ServerSpec" $ \tracer -> failAfter 5 $ withTempDir "ServerSpec" $ \tmpDir -> do let persistentFile = tmpDir <> "/history" arbitraryMsg <- generate arbitrary @@ -158,7 +158,7 @@ spec = describe "ServerSpec" $ monitor $ cover 0.1 (length outputs == 1) "only one message when reconnecting" monitor $ cover 1 (length outputs > 1) "more than one message when reconnecting" run $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withFreePort $ \port -> withTestAPIServer port alice mockPersistence tracer $ \Server{sendOutput} -> do mapM_ sendOutput outputs @@ -178,7 +178,7 @@ spec = describe "ServerSpec" $ monitor $ cover 0.1 (length history == 1) "only one message when reconnecting" monitor $ cover 1 (length history > 1) "more than one message when reconnecting" run $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withFreePort $ \port -> withTestAPIServer port alice mockPersistence tracer $ \Server{sendOutput} -> do let sendFromApiServer = sendOutput @@ -202,7 +202,7 @@ spec = describe "ServerSpec" $ (output <$> timedOutputs') `shouldBe` [notHistoryMessage] it "outputs tx as cbor or json depending on the client" $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withFreePort $ \port -> withTestAPIServer port alice mockPersistence tracer $ \Server{sendOutput} -> do tx :: SimpleTx <- generate arbitrary @@ -264,7 +264,7 @@ spec = describe "ServerSpec" $ guardForValue v (toJSON tx) it "removes UTXO from snapshot when clients request it" $ - showLogsOnFailure $ \tracer -> failAfter 5 $ + showLogsOnFailure "ServerSpec" $ \tracer -> failAfter 5 $ withFreePort $ \port -> withTestAPIServer port alice mockPersistence tracer $ \Server{sendOutput} -> do snapshot <- generate arbitrary @@ -285,7 +285,7 @@ spec = describe "ServerSpec" $ monadicIO $ do outputs :: [ServerOutput SimpleTx] <- pick arbitrary run $ - showLogsOnFailure $ \tracer -> failAfter 5 $ + showLogsOnFailure "ServerSpec" $ \tracer -> failAfter 5 $ withFreePort $ \port -> withTestAPIServer port alice mockPersistence tracer $ \Server{sendOutput} -> do mapM_ sendOutput outputs @@ -298,7 +298,7 @@ spec = describe "ServerSpec" $ seq <$> timedOutputs `shouldSatisfy` strictlyMonotonic it "displays correctly headStatus and snapshotUtxo in a Greeting message" $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withFreePort $ \port -> do -- Prime some relevant server outputs already into persistence to -- check whether the latest headStatus is loaded correctly. @@ -341,7 +341,7 @@ spec = describe "ServerSpec" $ guard $ v ^? key "snapshotUtxo" == Just (toJSON utxo') it "greets with correct head status and snapshot utxo after restart" $ - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withTempDir "api-server-head-status" $ \persistenceDir -> withFreePort $ \port -> do let generateSnapshot = @@ -379,7 +379,7 @@ strictlyMonotonic = \case sendsAnErrorWhenInputCannotBeDecoded :: PortNumber -> Expectation sendsAnErrorWhenInputCannotBeDecoded port = do - showLogsOnFailure $ \tracer -> + showLogsOnFailure "ServerSpec" $ \tracer -> withTestAPIServer port alice mockPersistence tracer $ \_server -> do withClient port "/" $ \con -> do _greeting :: ByteString <- receiveData con diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs index 769d1604f87..2dc5d79306c 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs @@ -11,7 +11,7 @@ import Hydra.Chain.Direct.TxSpec () import Cardano.Api.UTxO qualified as UTxO import Cardano.Ledger.Api (bodyTxL) import Cardano.Ledger.Api.Tx.Body (EraTxBody (outputsTxBodyL), setMinCoinTxOut) -import Control.Lens (mapped, (%~), (.~), (^.)) +import Control.Lens (mapped, (%~)) import Data.List qualified as List import Data.Maybe (fromJust) import Hydra.Chain.Direct.Contract.Gen (genMintedOrBurnedValue) diff --git a/hydra-node/test/Hydra/Network/AuthenticateSpec.hs b/hydra-node/test/Hydra/Network/AuthenticateSpec.hs index c18992922c3..c66aa5672dd 100644 --- a/hydra-node/test/Hydra/Network/AuthenticateSpec.hs +++ b/hydra-node/test/Hydra/Network/AuthenticateSpec.hs @@ -107,7 +107,7 @@ spec = parallel $ do let traced = runSimOrThrow $ do traces <- newTVarIO [] - let tracer = traceInTVar traces + let tracer = traceInTVar traces "AuthenticateSpec" withAuthentication tracer aliceSk [bob, carol] (\incoming _ -> incoming signedMsg) noop $ \_ -> threadDelay 1 diff --git a/hydra-node/test/Hydra/NetworkSpec.hs b/hydra-node/test/Hydra/NetworkSpec.hs index e9a8cf0bdcc..6353d57072c 100644 --- a/hydra-node/test/Hydra/NetworkSpec.hs +++ b/hydra-node/test/Hydra/NetworkSpec.hs @@ -10,10 +10,13 @@ import Codec.CBOR.Read (deserialiseFromBytes) import Codec.CBOR.Write (toLazyByteString) import Control.Concurrent.Class.MonadSTM (newTQueue, readTQueue, writeTQueue) import Hydra.Ledger.Simple (SimpleTx (..)) -import Hydra.Logging (showLogsOnFailure) +import Hydra.Logging (nullTracer, showLogsOnFailure) import Hydra.Network (Host (..), Network) import Hydra.Network.Message (Message (..)) import Hydra.Network.Ouroboros (broadcast, withOuroborosNetwork) +import Hydra.Network.Reliability (MessagePersistence (..)) +import Hydra.Node.Network (configureMessagePersistence) +import Hydra.Node.ParameterMismatch (ParameterMismatch) import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs) import Test.Network.Ports (randomUnusedTCPPorts) import Test.QuickCheck ( @@ -29,7 +32,7 @@ spec = do describe "Ouroboros Network" $ do it "broadcasts messages to single connected peer" $ do received <- atomically newTQueue - showLogsOnFailure $ \tracer -> failAfter 30 $ do + showLogsOnFailure "NetworkSpec" $ \tracer -> failAfter 30 $ do [port1, port2] <- fmap fromIntegral <$> randomUnusedTCPPorts 2 withOuroborosNetwork tracer (Host lo port1) [Host lo port2] (const @_ @Integer $ pure ()) $ \hn1 -> withOuroborosNetwork @Integer tracer (Host lo port2) [Host lo port1] (atomically . writeTQueue received) $ \_ -> do @@ -40,7 +43,7 @@ spec = do node1received <- atomically newTQueue node2received <- atomically newTQueue node3received <- atomically newTQueue - showLogsOnFailure $ \tracer -> failAfter 30 $ do + showLogsOnFailure "NetworkSpec" $ \tracer -> failAfter 30 $ do [port1, port2, port3] <- fmap fromIntegral <$> randomUnusedTCPPorts 3 withOuroborosNetwork @Integer tracer (Host lo port1) [Host lo port2, Host lo port3] (atomically . writeTQueue node1received) $ \hn1 -> withOuroborosNetwork tracer (Host lo port2) [Host lo port1, Host lo port3] (atomically . writeTQueue node2received) $ \hn2 -> do @@ -52,8 +55,15 @@ spec = do prop "can roundtrip CBOR encoding/decoding of Hydra Message" $ prop_canRoundtripCBOREncoding @(Message SimpleTx) roundtripAndGoldenSpecs (Proxy @(Message SimpleTx)) + describe "configureMessagePersistence" $ do + it "throws ParameterMismatch when configuring given number of acks does not match number of parties" $ do + withTempDir "persistence" $ \dir -> do + MessagePersistence{saveAcks} <- configureMessagePersistence @_ @Int nullTracer dir 3 + saveAcks (fromList [0, 0, 0]) + configureMessagePersistence @_ @Int nullTracer dir 4 `shouldThrow` (const True :: Selector ParameterMismatch) + withNodeBroadcastingForever :: Network IO Integer -> Integer -> IO b -> IO b -withNodeBroadcastingForever node value continuation = withNodesBroadcastingForever [(node, value)] continuation +withNodeBroadcastingForever node value = withNodesBroadcastingForever [(node, value)] withNodesBroadcastingForever :: [(Network IO Integer, Integer)] -> IO b -> IO b withNodesBroadcastingForever [] continuation = continuation diff --git a/hydra-node/test/Hydra/NodeSpec.hs b/hydra-node/test/Hydra/NodeSpec.hs index e24b5a919ec..72c3a2ffb01 100644 --- a/hydra-node/test/Hydra/NodeSpec.hs +++ b/hydra-node/test/Hydra/NodeSpec.hs @@ -39,13 +39,13 @@ import Hydra.Network.Message (Message (..)) import Hydra.Node ( HydraNode (..), HydraNodeLog (..), - ParameterMismatch (..), checkHeadState, createNodeState, loadState, stepHydraNode, ) import Hydra.Node.EventQueue (EventQueue (..), createEventQueue) +import Hydra.Node.ParameterMismatch (ParameterMismatch (..)) import Hydra.Options (defaultContestationPeriod) import Hydra.Party (Party, deriveParty) import Hydra.Persistence (PersistenceIncremental (..)) @@ -54,7 +54,7 @@ import Test.Hydra.Fixture (alice, aliceSk, bob, bobSk, carol, carolSk, cperiod) spec :: Spec spec = parallel $ do it "emits a single ReqSn and AckSn as leader, even after multiple ReqTxs" $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do -- NOTE(SN): Sequence of parties in OnInitTx of -- 'eventsToOpenHead' is relevant, so 10 is the (initial) snapshot leader let tx1 = SimpleTx{txSimpleId = 1, txInputs = utxoRefs [2], txOutputs = utxoRefs [4]} @@ -73,7 +73,7 @@ spec = parallel $ do getNetworkMessages `shouldReturn` [ReqSn 1 [1], AckSn signedSnapshot 1] it "rotates snapshot leaders" $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do let tx1 = SimpleTx{txSimpleId = 1, txInputs = utxoRefs [2], txOutputs = utxoRefs [4]} sn1 = testSnapshot 1 (utxoRefs [1, 2, 3]) mempty sn2 = testSnapshot 2 (utxoRefs [1, 3, 4]) [1] @@ -92,7 +92,7 @@ spec = parallel $ do getNetworkMessages `shouldReturn` [AckSn (sign bobSk sn1) 1, ReqSn 2 [1], AckSn (sign bobSk sn2) 2] it "processes out-of-order AckSn" $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do let snapshot = testSnapshot 1 (utxoRefs [1, 2, 3]) [] sigBob = sign bobSk snapshot sigAlice = sign aliceSk snapshot @@ -107,7 +107,7 @@ spec = parallel $ do getNetworkMessages `shouldReturn` [AckSn{signed = sigAlice, snapshotNumber = 1}] it "notifies client when postTx throws PostTxError" $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do let events = [ClientEvent Init] (node, getServerOutputs) <- createHydraNode aliceSk [bob, carol] cperiod events >>= throwExceptionOnPostTx NoSeedInput >>= recordServerOutputs @@ -118,7 +118,7 @@ spec = parallel $ do it "signs snapshot even if it has seen conflicting transactions" $ failAfter 1 $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do let snapshot = testSnapshot 1 (utxoRefs [1, 3, 5]) [2] sigBob = sign bobSk snapshot events = @@ -134,7 +134,7 @@ spec = parallel $ do it "can continue after restart via persisted state" $ failAfter 1 $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do persistence <- createPersistenceInMemory createHydraNode' persistence bobSk [alice, carol] defaultContestationPeriod eventsToOpenHead @@ -161,18 +161,18 @@ spec = parallel $ do headState = inInitialState [alice, bob] it "accepts configuration consistent with HeadState" $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do checkHeadState tracer defaultEnv headState `shouldReturn` () it "throws exception given contestation period differs" $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do let invalidPeriodEnv = defaultEnv{HeadLogic.contestationPeriod = defaultContestationPeriod} checkHeadState tracer invalidPeriodEnv headState `shouldThrow` \(_ :: ParameterMismatch) -> True it "throws exception given parties differ" $ - showLogsOnFailure $ \tracer -> do + showLogsOnFailure "NodeSpec" $ \tracer -> do let invalidPeriodEnv = defaultEnv{otherParties = []} checkHeadState tracer invalidPeriodEnv headState `shouldThrow` \(_ :: ParameterMismatch) -> True @@ -184,7 +184,7 @@ spec = parallel $ do Misconfiguration{} -> True _ -> False - checkHeadState (traceInTVar logs) invalidPeriodEnv headState + checkHeadState (traceInTVar logs "NodeSpec") invalidPeriodEnv headState `catch` \(_ :: ParameterMismatch) -> pure () entries <- fmap Logging.message <$> readTVarIO logs diff --git a/hydra-tui/test/Hydra/TUISpec.hs b/hydra-tui/test/Hydra/TUISpec.hs index 5f29ca41e1f..f7a5e746e92 100644 --- a/hydra-tui/test/Hydra/TUISpec.hs +++ b/hydra-tui/test/Hydra/TUISpec.hs @@ -144,7 +144,7 @@ spec = do setupNodeAndTUI' :: Lovelace -> (TUITest -> IO ()) -> IO () setupNodeAndTUI' lovelace action = - showLogsOnFailure $ \tracer -> + showLogsOnFailure "TUISpec" $ \tracer -> withTempDir "tui-end-to-end" $ \tmpDir -> do (aliceCardanoVk, _) <- keysFor Alice withCardanoNodeDevnet (contramap FromCardano tracer) tmpDir $ \node@RunningNode{nodeSocket, networkId} -> do