From 0dc6ab915d84d185d54728281353f114cf5712d4 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 5 Jan 2024 13:10:15 +0100 Subject: [PATCH 01/58] Add base e2e test for hydra-exporer To assert observations over stdout. --- hydra-cluster/hydra-cluster.cabal | 2 + hydra-cluster/test/Test/HydraExplorerSpec.hs | 150 +++++++++++++++++++ 2 files changed, 152 insertions(+) create mode 100644 hydra-cluster/test/Test/HydraExplorerSpec.hs diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index f9a126b2b9b..41040b89f25 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -157,6 +157,8 @@ test-suite tests Test.Hydra.Cluster.CardanoCliSpec Test.Hydra.Cluster.FaucetSpec Test.Hydra.Cluster.MithrilSpec + Test.HydraExplorerSpec + Test.LogFilterSpec Test.OfflineChainSpec build-depends: diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs new file mode 100644 index 00000000000..412705b6a0d --- /dev/null +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE DeriveAnyClass #-} +-- withCreateProcess interface is annoying +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Integration tests for the 'hydra-explorer' executable. These will run +-- also 'hydra-node' on a devnet and assert correct observation. +module Test.HydraExplorerSpec where + +import Hydra.Prelude +import Test.Hydra.Prelude + +import CardanoClient (NodeLog, RunningNode (..), submitTx) +import CardanoNode (withCardanoNodeDevnet) +import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) +import Control.Exception (IOException) +import Control.Lens ((^?)) +import Data.Aeson as Aeson +import Data.Aeson.Lens (key, _String) +import Data.ByteString (hGetLine) +import Data.Text qualified as T +import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile) +import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) +import Hydra.Cluster.Fixture (Actor (..), aliceSk, cperiod) +import Hydra.Cluster.Util (chainConfigFor, keysFor) +import Hydra.Logging (showLogsOnFailure) +import HydraNode (HydraNodeLog, input, output, requestCommitTx, send, waitFor, waitMatch, withHydraNode) +import System.IO.Error (isEOFError, isIllegalOperation) +import System.Process (CreateProcess (std_out), StdStream (..), proc, withCreateProcess) + +spec :: Spec +spec = do + it "can observe hydra transactions created by hydra-nodes" $ + failAfter 60 $ + showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do + withTempDir "hydra-explorer" $ \tmpDir -> do + -- Start a cardano devnet + withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket, pparams} -> do + -- Prepare a hydra-node + let hydraTracer = contramap FromHydraNode tracer + hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet + (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice + aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] pparams $ \hydraNode -> do + withHydraExplorer cardanoNode $ \explorer -> do + seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) + + send hydraNode $ input "Init" [] + + headId <- waitMatch 5 hydraNode $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsInitializing" + v ^? key "headId" . _String + + headExplorerSees explorer "HeadInitTx" headId + + requestCommitTx hydraNode mempty >>= submitTx cardanoNode + waitFor hydraTracer 5 [hydraNode] $ + output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] + + headExplorerSees explorer "HeadCommitTx" headId + headExplorerSees explorer "HeadCollectComTx" headId + + send hydraNode $ input "Close" [] + + headExplorerSees explorer "HeadCloseTx" headId + + waitFor hydraTracer 50 [hydraNode] $ + output "ReadyToFanout" ["headId" .= headId] + + send hydraNode $ input "Fanout" [] + + headExplorerSees explorer "HeadFanoutTx" headId + +headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () +headExplorerSees explorer txType headId = + awaitMatch explorer 5 $ \v -> do + guard $ v ^? key "message" . key "tag" == Just txType + let actualId = v ^? key "message" . key "headId" . _String + guard $ actualId == Just headId + +awaitMatch :: HasCallStack => HydraExplorerHandle -> DiffTime -> (Aeson.Value -> Maybe a) -> IO a +awaitMatch hydraExplorerHandle delay f = do + seenMsgs <- newTVarIO [] + timeout delay (go seenMsgs) >>= \case + Just x -> pure x + Nothing -> do + msgs <- readTVarIO seenMsgs + failure $ + toString $ + unlines + [ "awaitMatch did not match a message within " <> show delay + , padRight ' ' 20 " seen messages:" + <> unlines (align 20 (decodeUtf8 . Aeson.encode <$> msgs)) + ] + where + go seenMsgs = do + msg <- awaitNext hydraExplorerHandle + atomically (modifyTVar' seenMsgs (msg :)) + maybe (go seenMsgs) pure (f msg) + + align _ [] = [] + align n (h : q) = h : fmap (T.replicate n " " <>) q + +newtype HydraExplorerHandle = HydraExplorerHandle {awaitNext :: IO Value} + +data HydraExplorerLog + = FromCardanoNode NodeLog + | FromHydraNode HydraNodeLog + | FromFaucet FaucetLog + deriving (Eq, Show, Generic) + deriving anyclass (ToJSON) + +-- | Starts a 'hydra-explorer' on some Cardano network. +withHydraExplorer :: RunningNode -> (HydraExplorerHandle -> IO ()) -> IO () +withHydraExplorer cardanoNode action = + -- XXX: If this throws an IOException, 'withFile' invocations around mislead + -- to the file path opened (e.g. the cardano-node log file) in the test + -- failure output. Print the exception here to have some debuggability at + -- least. + handle (\(e :: IOException) -> print e >> throwIO e) $ + withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph -> + action + HydraExplorerHandle + { awaitNext = awaitNext out + } + where + awaitNext :: Handle -> IO Aeson.Value + awaitNext out = do + x <- try (hGetLine out) + case x of + Left e | isEOFError e || isIllegalOperation e -> do + threadDelay 1 + awaitNext out + Left e -> failure $ "awaitNext failed with exception " <> show e + Right d -> do + case Aeson.eitherDecode (fromStrict d) of + Left _err -> do + putBSLn $ "awaitNext failed to decode msg: " <> d + threadDelay 1 + awaitNext out + Right value -> pure value + + process = + proc + "hydra-explorer" + $ ["--node-socket", unFile nodeSocket] + <> case networkId of + Mainnet -> ["--mainnet"] + Testnet (NetworkMagic magic) -> ["--testnet-magic", show magic] + + RunningNode{nodeSocket, networkId} = cardanoNode From 590ac431ebded678273ac4abc6a2c975e6c85c08 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 5 Jan 2024 13:19:32 +0100 Subject: [PATCH 02/58] Create base explorer project Include changes to cabal and nix config files. --- cabal.project | 1 + .../hydra-chain-observer.cabal | 2 +- hydra-explorer/LICENSE | 202 ++++++++++++++++++ hydra-explorer/NOTICE | 14 ++ hydra-explorer/README.md | 12 ++ hydra-explorer/exe/Main.hs | 7 + hydra-explorer/hydra-explorer.cabal | 76 +++++++ hydra-explorer/src/Hydra/Explorer.hs | 6 + hydra-explorer/test/Main.hs | 12 ++ hydra-explorer/test/Spec.hs | 1 + nix/hydra/packages.nix | 7 + 11 files changed, 339 insertions(+), 1 deletion(-) create mode 100644 hydra-explorer/LICENSE create mode 100644 hydra-explorer/NOTICE create mode 100644 hydra-explorer/README.md create mode 100644 hydra-explorer/exe/Main.hs create mode 100644 hydra-explorer/hydra-explorer.cabal create mode 100644 hydra-explorer/src/Hydra/Explorer.hs create mode 100644 hydra-explorer/test/Main.hs create mode 100644 hydra-explorer/test/Spec.hs diff --git a/cabal.project b/cabal.project index faac256a994..390c5c9af4b 100644 --- a/cabal.project +++ b/cabal.project @@ -28,6 +28,7 @@ packages: hydra-tui hydraw hydra-chain-observer + hydra-explorer -- Compile more things in parallel package * diff --git a/hydra-chain-observer/hydra-chain-observer.cabal b/hydra-chain-observer/hydra-chain-observer.cabal index 752a16d3473..f9442c8bd32 100644 --- a/hydra-chain-observer/hydra-chain-observer.cabal +++ b/hydra-chain-observer/hydra-chain-observer.cabal @@ -16,6 +16,7 @@ source-repository head common project-config default-language: GHC2021 default-extensions: + NoImplicitPrelude BangPatterns BinaryLiterals ConstraintKinds @@ -41,7 +42,6 @@ common project-config MultiParamTypeClasses MultiWayIf NamedFieldPuns - NoImplicitPrelude NumericUnderscores OverloadedStrings PartialTypeSignatures diff --git a/hydra-explorer/LICENSE b/hydra-explorer/LICENSE new file mode 100644 index 00000000000..b6ddde7af57 --- /dev/null +++ b/hydra-explorer/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [2021-2022] [IOG] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/hydra-explorer/NOTICE b/hydra-explorer/NOTICE new file mode 100644 index 00000000000..f1f56f0d1ef --- /dev/null +++ b/hydra-explorer/NOTICE @@ -0,0 +1,14 @@ +Copyright 2023 Input Output Global Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/hydra-explorer/README.md b/hydra-explorer/README.md new file mode 100644 index 00000000000..d2218a2b14e --- /dev/null +++ b/hydra-explorer/README.md @@ -0,0 +1,12 @@ +# Hydra Explorer + +A small executable which connects to a chain like the `hydra-node`, but puts any +observations as traces onto `stdout`. + +To run, pass a `--node-socket`, corresponding network id. For example: + +``` shell +hydra-explorer \ + --node-socket testnets/preprod/node.socket \ + --testnet-magic 1 \ +``` diff --git a/hydra-explorer/exe/Main.hs b/hydra-explorer/exe/Main.hs new file mode 100644 index 00000000000..9ef25b468fb --- /dev/null +++ b/hydra-explorer/exe/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Hydra.Explorer qualified +import Hydra.Prelude + +main :: IO () +main = Hydra.Explorer.main diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal new file mode 100644 index 00000000000..f3e6201b385 --- /dev/null +++ b/hydra-explorer/hydra-explorer.cabal @@ -0,0 +1,76 @@ +cabal-version: 2.2 +name: hydra-explorer +version: 0.15.0 +synopsis: Hydra Explorer +author: IOG +copyright: 2023 IOG +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +source-repository head + type: git + location: https://github.com/input-output-hk/hydra/hydra-explorer/ + +common project-config + default-language: GHC2021 + default-extensions: + NoImplicitPrelude + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DerivingStrategies + DuplicateRecordFields + FunctionalDependencies + GADTs + LambdaCase + MultiWayIf + OverloadedStrings + PartialTypeSignatures + PatternSynonyms + TypeFamilies + ViewPatterns + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages + -fprint-potential-instances + +library + import: project-config + hs-source-dirs: src + ghc-options: -haddock + build-depends: + , hydra-chain-observer + , hydra-node + , hydra-prelude + , optparse-applicative + + exposed-modules: Hydra.Explorer + +executable hydra-explorer + import: project-config + hs-source-dirs: exe + main-is: Main.hs + build-depends: + , hydra-explorer + , hydra-prelude + +test-suite tests + import: project-config + ghc-options: -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: test + main-is: Main.hs + type: exitcode-stdio-1.0 + build-depends: + , hspec + , hydra-explorer + , hydra-node + , hydra-prelude + , hydra-test-utils + , QuickCheck + + other-modules: Spec + build-tool-depends: hspec-discover:hspec-discover diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs new file mode 100644 index 00000000000..1a5303d7871 --- /dev/null +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -0,0 +1,6 @@ +module Hydra.Explorer where + +import Hydra.Prelude + +main :: IO () +main = pure () diff --git a/hydra-explorer/test/Main.hs b/hydra-explorer/test/Main.hs new file mode 100644 index 00000000000..039506c3cd4 --- /dev/null +++ b/hydra-explorer/test/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Hydra.Prelude +import Spec qualified +import Test.Hspec.Runner +import Test.Hydra.Prelude (combinedHspecFormatter) + +main :: IO () +main = + hspecWith + defaultConfig{configFormat = Just (combinedHspecFormatter "hydra-explorer")} + Spec.spec diff --git a/hydra-explorer/test/Spec.hs b/hydra-explorer/test/Spec.hs new file mode 100644 index 00000000000..5416ef6a866 --- /dev/null +++ b/hydra-explorer/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/nix/hydra/packages.nix b/nix/hydra/packages.nix index f98c8597bf5..99a6b2f26b1 100644 --- a/nix/hydra/packages.nix +++ b/nix/hydra/packages.nix @@ -89,6 +89,12 @@ rec { hydra-chain-observer-static = musl64Pkgs.hydra-chain-observer.components.exes.hydra-chain-observer; + + hydra-explorer = + nativePkgs.hydra-explorer.components.exes.hydra-explorer; + + hydra-explorer-static = + musl64Pkgs.hydra-explorer.components.exes.hydra-explorer; hydra-tui = embedRevision @@ -137,6 +143,7 @@ rec { inputs.cardano-node.packages.${system}.cardano-cli inputs.mithril.packages.${system}.mithril-client-cli pkgs.check-jsonschema + hydra-explorer ]; }; hydra-tui = pkgs.mkShellNoCC { From e814444992b3d045f612055bac858dd73b050dba Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 5 Jan 2024 13:33:28 +0100 Subject: [PATCH 03/58] Reuse the hydra-chain-observer library code to collect the observations --- hydra-explorer/src/Hydra/Explorer.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 1a5303d7871..a710e99e144 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -1,6 +1,7 @@ module Hydra.Explorer where +import Hydra.ChainObserver qualified import Hydra.Prelude main :: IO () -main = pure () +main = Hydra.ChainObserver.main From baaa2672e47fa3ff29c8dfd2c955dd3f7bcf59cf Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Wed, 10 Jan 2024 14:38:01 +0100 Subject: [PATCH 04/58] Fix after rebase: remove pparams arg from withHydraNode process --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 412705b6a0d..ba5d53ea2f6 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -34,13 +34,13 @@ spec = do showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do withTempDir "hydra-explorer" $ \tmpDir -> do -- Start a cardano devnet - withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket, pparams} -> do + withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do -- Prepare a hydra-node let hydraTracer = contramap FromHydraNode tracer hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] pparams $ \hydraNode -> do + withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do withHydraExplorer cardanoNode $ \explorer -> do seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) From 5cb234762a019b3615902296255cc0866dee902c Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Wed, 10 Jan 2024 17:14:24 +0100 Subject: [PATCH 05/58] Add GET /heads e2e spec --- .../hydra-chain-observer.cabal | 2 +- hydra-cluster/hydra-cluster.cabal | 3 ++ hydra-cluster/test/Test/HydraExplorerSpec.hs | 42 ++++++++++++++++++- hydra-explorer/hydra-explorer.cabal | 2 +- nix/hydra/packages.nix | 2 +- 5 files changed, 47 insertions(+), 4 deletions(-) diff --git a/hydra-chain-observer/hydra-chain-observer.cabal b/hydra-chain-observer/hydra-chain-observer.cabal index f9442c8bd32..752a16d3473 100644 --- a/hydra-chain-observer/hydra-chain-observer.cabal +++ b/hydra-chain-observer/hydra-chain-observer.cabal @@ -16,7 +16,6 @@ source-repository head common project-config default-language: GHC2021 default-extensions: - NoImplicitPrelude BangPatterns BinaryLiterals ConstraintKinds @@ -42,6 +41,7 @@ common project-config MultiParamTypeClasses MultiWayIf NamedFieldPuns + NoImplicitPrelude NumericUnderscores OverloadedStrings PartialTypeSignatures diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index 41040b89f25..797da5df7dd 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -170,6 +170,9 @@ test-suite tests , directory , filepath , hspec + , http-client + , http-client-tls + , http-types , hydra-cardano-api , hydra-cluster , hydra-node:{hydra-node, testlib} diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index ba5d53ea2f6..e2e957350ad 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -6,7 +6,7 @@ -- also 'hydra-node' on a devnet and assert correct observation. module Test.HydraExplorerSpec where -import Hydra.Prelude +import Hydra.Prelude hiding (get) import Test.Hydra.Prelude import CardanoClient (NodeLog, RunningNode (..), submitTx) @@ -22,8 +22,12 @@ import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile) import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) import Hydra.Cluster.Fixture (Actor (..), aliceSk, cperiod) import Hydra.Cluster.Util (chainConfigFor, keysFor) +import Hydra.HeadId (HeadId (..)) import Hydra.Logging (showLogsOnFailure) import HydraNode (HydraNodeLog, input, output, requestCommitTx, send, waitFor, waitMatch, withHydraNode) +import Network.HTTP.Client qualified as HTTPClient +import Network.HTTP.Client.TLS qualified as HTTPClient +import Network.HTTP.Types.Status (status200) import System.IO.Error (isEOFError, isIllegalOperation) import System.Process (CreateProcess (std_out), StdStream (..), proc, withCreateProcess) @@ -70,6 +74,42 @@ spec = do headExplorerSees explorer "HeadFanoutTx" headId + it "can query for all hydra heads observed" $ + failAfter 60 $ + showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do + withTempDir "hydra-explorer-get-heads" $ \tmpDir -> do + -- Start a cardano devnet + withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do + -- Prepare a hydra-node + let hydraTracer = contramap FromHydraNode tracer + hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet + (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice + aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do + withHydraExplorer cardanoNode $ \explorer -> do + seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) + + send hydraNode $ input "Init" [] + + headId <- waitMatch 5 hydraNode $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsInitializing" + v ^? key "headId" . _String + + headExplorerSees explorer "HeadInitTx" headId + + manager <- HTTPClient.newTlsManager + let url = "https://127.0.0.1:9000/heads?page=0" + request <- + HTTPClient.parseRequest url <&> \request -> + request + { HTTPClient.method = "GET" + , HTTPClient.requestHeaders = [("Accept", "application/json")] + } + response <- HTTPClient.httpLbs request manager + HTTPClient.responseStatus response `shouldBe` status200 + let maybeOpenHeads = decode $ HTTPClient.responseBody response :: Maybe [HeadId] + maybeOpenHeads `shouldBe` Just [UnsafeHeadId $ encodeUtf8 headId] + headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () headExplorerSees explorer txType headId = awaitMatch explorer 5 $ \v -> do diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index f3e6201b385..89d098805c3 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -16,7 +16,6 @@ source-repository head common project-config default-language: GHC2021 default-extensions: - NoImplicitPrelude DataKinds DefaultSignatures DeriveAnyClass @@ -27,6 +26,7 @@ common project-config GADTs LambdaCase MultiWayIf + NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternSynonyms diff --git a/nix/hydra/packages.nix b/nix/hydra/packages.nix index 99a6b2f26b1..95d79c0a22d 100644 --- a/nix/hydra/packages.nix +++ b/nix/hydra/packages.nix @@ -89,7 +89,7 @@ rec { hydra-chain-observer-static = musl64Pkgs.hydra-chain-observer.components.exes.hydra-chain-observer; - + hydra-explorer = nativePkgs.hydra-explorer.components.exes.hydra-explorer; From 13a0cc6795a452599088d1b81660bb893cbef358 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Wed, 10 Jan 2024 23:20:30 +0100 Subject: [PATCH 06/58] Draft http server for explorer --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 3 +- hydra-explorer/hydra-explorer.cabal | 7 ++ hydra-explorer/src/Hydra/Explorer.hs | 84 +++++++++++++++++++- 3 files changed, 92 insertions(+), 2 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index e2e957350ad..34309084758 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -98,7 +98,7 @@ spec = do headExplorerSees explorer "HeadInitTx" headId manager <- HTTPClient.newTlsManager - let url = "https://127.0.0.1:9000/heads?page=0" + let url = "http://127.0.0.1:9090/heads?page=1" request <- HTTPClient.parseRequest url <&> \request -> request @@ -107,6 +107,7 @@ spec = do } response <- HTTPClient.httpLbs request manager HTTPClient.responseStatus response `shouldBe` status200 + print (HTTPClient.responseBody response) let maybeOpenHeads = decode $ HTTPClient.responseBody response :: Maybe [HeadId] maybeOpenHeads `shouldBe` Just [UnsafeHeadId $ encodeUtf8 headId] diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index 89d098805c3..d97015009f8 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -43,10 +43,17 @@ library hs-source-dirs: src ghc-options: -haddock build-depends: + , aeson + , base + , bytestring + , containers + , http-types , hydra-chain-observer , hydra-node , hydra-prelude , optparse-applicative + , wai + , warp exposed-modules: Hydra.Explorer diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index a710e99e144..4ea8ed03dc8 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -3,5 +3,87 @@ module Hydra.Explorer where import Hydra.ChainObserver qualified import Hydra.Prelude +import Data.ByteString.Char8 (unpack) +import Data.List qualified as List +import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) +import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) +import Hydra.Network (PortNumber) +import Network.HTTP.Types (parseQuery, status200) +import Network.HTTP.Types.Header (HeaderName) +import Network.HTTP.Types.Status (status404, status500) +import Network.Wai ( + Application, + Response, + pathInfo, + rawPathInfo, + rawQueryString, + requestMethod, + responseFile, + responseLBS, + ) +import Network.Wai.Handler.Warp qualified as Warp +import Prelude (read) + main :: IO () -main = Hydra.ChainObserver.main +main = do + withTracer (Verbose "hydra-explorer") $ \tracer -> do + race + Hydra.ChainObserver.main + ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) + *> Warp.runSettings (settings tracer) (httpApp tracer) + ) + >>= \case + Left{} -> error "Something went wrong" + Right a -> pure a + where + port = 9090 + + settings tracer = + Warp.defaultSettings + & Warp.setPort port + & Warp.setHost "0.0.0.0" + & Warp.setOnException (\_ e -> traceWith tracer $ APIConnectionError{reason = show e}) + & Warp.setBeforeMainLoop + ( do + putStrLn "Server started..." + putStrLn $ "Listening on: tcp/" <> show port + ) + +httpApp :: Tracer IO APIServerLog -> Application +httpApp tracer req send = do + traceWith tracer $ + APIHTTPRequestReceived + { method = Method $ requestMethod req + , path = PathInfo $ rawPathInfo req + } + case (requestMethod req, pathInfo req) of + ("HEAD", _) -> send $ responseLBS status200 corsHeaders "" + ("GET", []) -> send $ handleFile "index.html" + ("GET", ["heads"]) -> do + let queryParams = parseQuery $ rawQueryString req + pageParam = join $ List.lookup "page" queryParams + page :: Int = maybe 0 (read . unpack) pageParam + send $ + responseLBS status200 corsHeaders $ + "OK. Handling /heads route with pagination. Page: " <> show page + -- FIXME: do proper file serving, this is dangerous + ("GET", path) -> send $ handleFile $ toString $ mconcat $ List.intersperse "/" ("." : path) + (_, _) -> send handleNotFound + +handleError :: Response +handleError = + responseLBS status500 corsHeaders "INVALID REQUEST" + +handleNotFound :: Response +handleNotFound = + responseLBS status404 corsHeaders "NOT FOUND" + +handleFile :: FilePath -> Response +handleFile filepath = responseFile status200 corsHeaders filepath Nothing + +corsHeaders :: [(HeaderName, ByteString)] +corsHeaders = + [ ("Access-Control-Allow-Origin", "*") + , ("Access-Control-Allow-Methods", "*") + , ("Access-Control-Allow-Headers", "*") + ] From 73f5cddca60ac80b566fed9419308dddf60ba892 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 11 Jan 2024 13:45:52 +0100 Subject: [PATCH 07/58] Introduce ObserverHandler as callback to chain-observer As a mean for clients to perform actions on every observation (like: keeping state) --- hydra-chain-observer/exe/Main.hs | 3 ++- .../src/Hydra/ChainObserver.hs | 9 ++++++-- hydra-explorer/hydra-explorer.cabal | 2 ++ hydra-explorer/src/Hydra/Explorer.hs | 22 ++++++++++++++----- 4 files changed, 28 insertions(+), 8 deletions(-) diff --git a/hydra-chain-observer/exe/Main.hs b/hydra-chain-observer/exe/Main.hs index fcc93aed584..2450e080137 100644 --- a/hydra-chain-observer/exe/Main.hs +++ b/hydra-chain-observer/exe/Main.hs @@ -1,7 +1,8 @@ module Main where +import Hydra.ChainObserver (defaultObserverHandler) import Hydra.ChainObserver qualified import Hydra.Prelude main :: IO () -main = Hydra.ChainObserver.main +main = Hydra.ChainObserver.main defaultObserverHandler diff --git a/hydra-chain-observer/src/Hydra/ChainObserver.hs b/hydra-chain-observer/src/Hydra/ChainObserver.hs index f9034408561..2b11fafd440 100644 --- a/hydra-chain-observer/src/Hydra/ChainObserver.hs +++ b/hydra-chain-observer/src/Hydra/ChainObserver.hs @@ -52,8 +52,13 @@ import Ouroboros.Network.Protocol.ChainSync.Client ( ClientStNext (..), ) -main :: IO () -main = do +type ObserverHandler = ChainPoint -> [(TxId, HeadObservation)] -> IO () + +defaultObserverHandler :: ObserverHandler +defaultObserverHandler = const . const $ pure () + +main :: ObserverHandler -> IO () +main observerHandler = do Options{networkId, nodeSocket, startChainFrom} <- execParser hydraChainObserverOptions withTracer (Verbose "hydra-chain-observer") $ \tracer -> do traceWith tracer KnownScripts{scriptInfo = Contract.scriptInfo} diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index d97015009f8..ee1c1fd75b7 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -48,9 +48,11 @@ library , bytestring , containers , http-types + , hydra-cardano-api , hydra-chain-observer , hydra-node , hydra-prelude + , io-classes , optparse-applicative , wai , warp diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 4ea8ed03dc8..3f025c7974d 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -3,9 +3,13 @@ module Hydra.Explorer where import Hydra.ChainObserver qualified import Hydra.Prelude +import Control.Concurrent.Class.MonadSTM (atomically, modifyTVar', newTVarIO) import Data.ByteString.Char8 (unpack) import Data.List qualified as List +import Data.Map.Strict qualified as Map import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) +import Hydra.Cardano.Api (ChainPoint, TxId) +import Hydra.Chain.Direct.Tx (HeadObservation) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) import Hydra.Network (PortNumber) import Network.HTTP.Types (parseQuery, status200) @@ -24,13 +28,21 @@ import Network.Wai ( import Network.Wai.Handler.Warp qualified as Warp import Prelude (read) +type ExplorerState = Map ChainPoint [(TxId, HeadObservation)] + +observerHandler :: TVar IO ExplorerState -> ChainPoint -> [(TxId, HeadObservation)] -> IO () +observerHandler explorerState point observations = + atomically $ + modifyTVar' explorerState (Map.insert point observations) + main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do + explorerState <- newTVarIO (mempty :: ExplorerState) race - Hydra.ChainObserver.main + (Hydra.ChainObserver.main (observerHandler explorerState)) ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) - *> Warp.runSettings (settings tracer) (httpApp tracer) + *> Warp.runSettings (settings tracer) (httpApp tracer explorerState) ) >>= \case Left{} -> error "Something went wrong" @@ -49,8 +61,8 @@ main = do putStrLn $ "Listening on: tcp/" <> show port ) -httpApp :: Tracer IO APIServerLog -> Application -httpApp tracer req send = do +httpApp :: Tracer IO APIServerLog -> TVar IO ExplorerState -> Application +httpApp tracer explorerState req send = do traceWith tracer $ APIHTTPRequestReceived { method = Method $ requestMethod req @@ -62,7 +74,7 @@ httpApp tracer req send = do ("GET", ["heads"]) -> do let queryParams = parseQuery $ rawQueryString req pageParam = join $ List.lookup "page" queryParams - page :: Int = maybe 0 (read . unpack) pageParam + page :: Int = maybe 0 (Prelude.read . unpack) pageParam send $ responseLBS status200 corsHeaders $ "OK. Handling /heads route with pagination. Page: " <> show page From 5273ccc52b61c5f420d13847ec73ed71912a549b Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 11 Jan 2024 17:24:16 +0100 Subject: [PATCH 08/58] Simplify endpoint --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 2 +- hydra-explorer/src/Hydra/Explorer.hs | 15 +++------------ 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 34309084758..760a9cdab82 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -98,7 +98,7 @@ spec = do headExplorerSees explorer "HeadInitTx" headId manager <- HTTPClient.newTlsManager - let url = "http://127.0.0.1:9090/heads?page=1" + let url = "http://127.0.0.1:9090/heads" request <- HTTPClient.parseRequest url <&> \request -> request diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 3f025c7974d..920c3cf0654 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -3,8 +3,7 @@ module Hydra.Explorer where import Hydra.ChainObserver qualified import Hydra.Prelude -import Control.Concurrent.Class.MonadSTM (atomically, modifyTVar', newTVarIO) -import Data.ByteString.Char8 (unpack) +import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO) import Data.List qualified as List import Data.Map.Strict qualified as Map import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) @@ -12,7 +11,7 @@ import Hydra.Cardano.Api (ChainPoint, TxId) import Hydra.Chain.Direct.Tx (HeadObservation) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) import Hydra.Network (PortNumber) -import Network.HTTP.Types (parseQuery, status200) +import Network.HTTP.Types (status200) import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Status (status404, status500) import Network.Wai ( @@ -20,13 +19,11 @@ import Network.Wai ( Response, pathInfo, rawPathInfo, - rawQueryString, requestMethod, responseFile, responseLBS, ) import Network.Wai.Handler.Warp qualified as Warp -import Prelude (read) type ExplorerState = Map ChainPoint [(TxId, HeadObservation)] @@ -71,13 +68,7 @@ httpApp tracer explorerState req send = do case (requestMethod req, pathInfo req) of ("HEAD", _) -> send $ responseLBS status200 corsHeaders "" ("GET", []) -> send $ handleFile "index.html" - ("GET", ["heads"]) -> do - let queryParams = parseQuery $ rawQueryString req - pageParam = join $ List.lookup "page" queryParams - page :: Int = maybe 0 (Prelude.read . unpack) pageParam - send $ - responseLBS status200 corsHeaders $ - "OK. Handling /heads route with pagination. Page: " <> show page + ("GET", ["heads"]) -> send $ responseLBS status200 corsHeaders "OK" -- FIXME: do proper file serving, this is dangerous ("GET", path) -> send $ handleFile $ toString $ mconcat $ List.intersperse "/" ("." : path) (_, _) -> send handleNotFound From 5a1cb534934f2954774b649a1a57f328755e4882 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 11 Jan 2024 17:51:47 +0100 Subject: [PATCH 09/58] Add e2e spec to explore multiple heads in the past --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 59 ++++++++++++++++++-- 1 file changed, 54 insertions(+), 5 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 760a9cdab82..11b17a3a75f 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -20,7 +20,7 @@ import Data.ByteString (hGetLine) import Data.Text qualified as T import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile) import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) -import Hydra.Cluster.Fixture (Actor (..), aliceSk, cperiod) +import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod) import Hydra.Cluster.Util (chainConfigFor, keysFor) import Hydra.HeadId (HeadId (..)) import Hydra.Logging (showLogsOnFailure) @@ -33,13 +33,11 @@ import System.Process (CreateProcess (std_out), StdStream (..), proc, withCreate spec :: Spec spec = do - it "can observe hydra transactions created by hydra-nodes" $ + it "can observe hydra transactions live" $ failAfter 60 $ showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do - withTempDir "hydra-explorer" $ \tmpDir -> do - -- Start a cardano devnet + withTempDir "hydra-explorer-live" $ \tmpDir -> do withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do - -- Prepare a hydra-node let hydraTracer = contramap FromHydraNode tracer hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice @@ -74,6 +72,57 @@ spec = do headExplorerSees explorer "HeadFanoutTx" headId + it "can observe hydra transactions created by multiple hydra-nodes" $ + failAfter 60 $ + showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do + withTempDir "hydra-explorer-history" $ \tmpDir -> do + withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do + let hydraTracer = contramap FromHydraNode tracer + hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet + (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice + aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do + seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) + + send hydraNode $ input "Init" [] + + headId <- waitMatch 5 hydraNode $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsInitializing" + v ^? key "headId" . _String + + requestCommitTx hydraNode mempty >>= submitTx cardanoNode + waitFor hydraTracer 5 [hydraNode] $ + output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] + + send hydraNode $ input "Close" [] + + pure headId + + (bobCardanoVk, _bobCardanoSk) <- keysFor Bob + bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod + bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] $ \hydraNode -> do + seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) + + send hydraNode $ input "Init" [] + + headId <- waitMatch 5 hydraNode $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsInitializing" + v ^? key "headId" . _String + + requestCommitTx hydraNode mempty >>= submitTx cardanoNode + waitFor hydraTracer 5 [hydraNode] $ + output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] + + send hydraNode $ input "Close" [] + + pure headId + + withHydraExplorer cardanoNode $ \explorer -> do + headExplorerSees explorer "HeadIsInitializing" aliceHeadId + headExplorerSees explorer "HeadIsClosed" aliceHeadId + headExplorerSees explorer "HeadIsInitializing" bobHeadId + headExplorerSees explorer "HeadIsClosed" aliceHeadId + it "can query for all hydra heads observed" $ failAfter 60 $ showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do From 8ccfdf1ac9d158b033c57e670c5efb529a2a6afe Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 11 Jan 2024 18:19:00 +0100 Subject: [PATCH 10/58] Add check process has not die to hydra-explorer in e2e specs --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 11b17a3a75f..a030c6fe1e8 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -29,7 +29,7 @@ import Network.HTTP.Client qualified as HTTPClient import Network.HTTP.Client.TLS qualified as HTTPClient import Network.HTTP.Types.Status (status200) import System.IO.Error (isEOFError, isIllegalOperation) -import System.Process (CreateProcess (std_out), StdStream (..), proc, withCreateProcess) +import System.Process (CreateProcess (..), StdStream (..), proc, withCreateProcess) spec :: Spec spec = do @@ -207,11 +207,12 @@ withHydraExplorer cardanoNode action = -- failure output. Print the exception here to have some debuggability at -- least. handle (\(e :: IOException) -> print e >> throwIO e) $ - withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph -> - action - HydraExplorerHandle - { awaitNext = awaitNext out - } + withCreateProcess process{std_out = CreatePipe, std_err = CreatePipe} $ + \_in (Just out) err processHandle -> + race + (checkProcessHasNotDied "hydra-explorer" processHandle err) + (action HydraExplorerHandle{awaitNext = awaitNext out}) + <&> either absurd id where awaitNext :: Handle -> IO Aeson.Value awaitNext out = do From 3b7822daf3aa5287d7e57148edf82e3a572797d7 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 12 Jan 2024 09:33:02 +0100 Subject: [PATCH 11/58] Fix minor typo on observations --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index a030c6fe1e8..ca957920479 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -118,18 +118,16 @@ spec = do pure headId withHydraExplorer cardanoNode $ \explorer -> do - headExplorerSees explorer "HeadIsInitializing" aliceHeadId - headExplorerSees explorer "HeadIsClosed" aliceHeadId - headExplorerSees explorer "HeadIsInitializing" bobHeadId - headExplorerSees explorer "HeadIsClosed" aliceHeadId + headExplorerSees explorer "HeadInitTx" aliceHeadId + headExplorerSees explorer "HeadCloseTx" aliceHeadId + headExplorerSees explorer "HeadInitTx" bobHeadId + headExplorerSees explorer "HeadCloseTx" aliceHeadId it "can query for all hydra heads observed" $ failAfter 60 $ showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do withTempDir "hydra-explorer-get-heads" $ \tmpDir -> do - -- Start a cardano devnet withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do - -- Prepare a hydra-node let hydraTracer = contramap FromHydraNode tracer hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice From 184cc2c529aa3a8bc24fd6d3b2de6a34c971578a Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 12 Jan 2024 09:41:24 +0100 Subject: [PATCH 12/58] Make hydra-cluster depend on hydra-explorer to run tests This avoids need for installing the binary --- hydra-cluster/hydra-cluster.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index 797da5df7dd..4d9250ca66e 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -190,6 +190,7 @@ test-suite tests build-tool-depends: , hspec-discover:hspec-discover , hydra-chain-observer:hydra-chain-observer + , hydra-explorer:hydra-explorer , hydra-node:hydra-node ghc-options: -threaded -rtsopts From 844ca02aac6cebaf1204e5441f2f4bbbbfb1202c Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 12 Jan 2024 09:41:34 +0100 Subject: [PATCH 13/58] Add point to RollForward to see slots pass --- hydra-chain-observer/src/Hydra/ChainObserver.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/hydra-chain-observer/src/Hydra/ChainObserver.hs b/hydra-chain-observer/src/Hydra/ChainObserver.hs index 2b11fafd440..19d26a4cb5e 100644 --- a/hydra-chain-observer/src/Hydra/ChainObserver.hs +++ b/hydra-chain-observer/src/Hydra/ChainObserver.hs @@ -21,6 +21,7 @@ import Hydra.Cardano.Api ( SocketPath, Tx, UTxO, + chainTipToChainPoint, connectToLocalNode, getTxBody, getTxId, @@ -84,7 +85,7 @@ data ChainObserverLog | HeadAbortTx {headId :: HeadId} | HeadContestTx {headId :: HeadId} | Rollback {point :: ChainPoint} - | RollForward {receivedTxIds :: [TxId]} + | RollForward {point :: ChainPoint, receivedTxIds :: [TxId]} deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) @@ -148,16 +149,17 @@ chainSyncClient tracer networkId startingPoint = ChainSyncClient $ throwIO (IntersectionNotFound startingPoint) } - clientStIdle :: UTxO -> ClientStIdle BlockType ChainPoint tip m () + clientStIdle :: UTxO -> ClientStIdle BlockType ChainPoint ChainTip m () clientStIdle utxo = SendMsgRequestNext (clientStNext utxo) (pure $ clientStNext utxo) - clientStNext :: UTxO -> ClientStNext BlockType ChainPoint tip m () + clientStNext :: UTxO -> ClientStNext BlockType ChainPoint ChainTip m () clientStNext utxo = ClientStNext - { recvMsgRollForward = \blockInMode _tip -> ChainSyncClient $ do + { recvMsgRollForward = \blockInMode tip -> ChainSyncClient $ do case blockInMode of BlockInMode _ (Block _header txs) BabbageEraInCardanoMode -> do - traceWith tracer RollForward{receivedTxIds = getTxId . getTxBody <$> txs} + let point = chainTipToChainPoint tip + traceWith tracer RollForward{point, receivedTxIds = getTxId . getTxBody <$> txs} let (utxo', logs) = observeAll networkId utxo txs forM_ logs (traceWith tracer) pure $ clientStIdle utxo' From d59722222ee9a7b48bb6afffac55bcd52737b87b Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 12 Jan 2024 09:48:31 +0100 Subject: [PATCH 14/58] Refactor explorer e2e test slightly --- hydra-cluster/test/Test/ChainObserverSpec.hs | 4 -- hydra-cluster/test/Test/HydraExplorerSpec.hs | 50 +++++++------------- 2 files changed, 17 insertions(+), 37 deletions(-) diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index 5e97b53bc5f..f066808f50b 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -112,10 +112,6 @@ data ChainObserverLog -- | Starts a 'hydra-chain-observer' on some Cardano network. withChainObserver :: RunningNode -> (ChainObserverHandle -> IO ()) -> IO () withChainObserver cardanoNode action = - -- XXX: If this throws an IOException, 'withFile' invocations around mislead - -- to the file path opened (e.g. the cardano-node log file) in the test - -- failure output. Print the exception here to have some debuggability at - -- least. handle (\(e :: IOException) -> print e >> throwIO e) $ withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph -> action diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index ca957920479..16af7532180 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -79,43 +79,31 @@ spec = do withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do let hydraTracer = contramap FromHydraNode tracer hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet - (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice - aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do - seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) - send hydraNode $ input "Init" [] + let initAndCloseHead hydraNode = do + send hydraNode $ input "Init" [] + + headId <- waitMatch 5 hydraNode $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsInitializing" + v ^? key "headId" . _String - headId <- waitMatch 5 hydraNode $ \v -> do - guard $ v ^? key "tag" == Just "HeadIsInitializing" - v ^? key "headId" . _String + requestCommitTx hydraNode mempty >>= submitTx cardanoNode + waitFor hydraTracer 5 [hydraNode] $ + output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] - requestCommitTx hydraNode mempty >>= submitTx cardanoNode - waitFor hydraTracer 5 [hydraNode] $ - output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] + send hydraNode $ input "Close" [] - send hydraNode $ input "Close" [] + pure headId - pure headId + (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice + seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) + aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] initAndCloseHead (bobCardanoVk, _bobCardanoSk) <- keysFor Bob + seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod - bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] $ \hydraNode -> do - seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) - - send hydraNode $ input "Init" [] - - headId <- waitMatch 5 hydraNode $ \v -> do - guard $ v ^? key "tag" == Just "HeadIsInitializing" - v ^? key "headId" . _String - - requestCommitTx hydraNode mempty >>= submitTx cardanoNode - waitFor hydraTracer 5 [hydraNode] $ - output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] - - send hydraNode $ input "Close" [] - - pure headId + bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initAndCloseHead withHydraExplorer cardanoNode $ \explorer -> do headExplorerSees explorer "HeadInitTx" aliceHeadId @@ -200,10 +188,6 @@ data HydraExplorerLog -- | Starts a 'hydra-explorer' on some Cardano network. withHydraExplorer :: RunningNode -> (HydraExplorerHandle -> IO ()) -> IO () withHydraExplorer cardanoNode action = - -- XXX: If this throws an IOException, 'withFile' invocations around mislead - -- to the file path opened (e.g. the cardano-node log file) in the test - -- failure output. Print the exception here to have some debuggability at - -- least. handle (\(e :: IOException) -> print e >> throwIO e) $ withCreateProcess process{std_out = CreatePipe, std_err = CreatePipe} $ \_in (Just out) err processHandle -> From 4b6ec507a8e19798c26955a88667f1747058fea4 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 12 Jan 2024 09:58:54 +0100 Subject: [PATCH 15/58] Start explorer from genesis --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 19 ++++--------------- hydra-explorer/src/Hydra/Explorer.hs | 5 ++++- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 16af7532180..ca62f18b7d7 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -80,36 +80,25 @@ spec = do let hydraTracer = contramap FromHydraNode tracer hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet - let initAndCloseHead hydraNode = do + let initHead hydraNode = do send hydraNode $ input "Init" [] - - headId <- waitMatch 5 hydraNode $ \v -> do + waitMatch 5 hydraNode $ \v -> do guard $ v ^? key "tag" == Just "HeadIsInitializing" v ^? key "headId" . _String - requestCommitTx hydraNode mempty >>= submitTx cardanoNode - waitFor hydraTracer 5 [hydraNode] $ - output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] - - send hydraNode $ input "Close" [] - - pure headId - (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] initAndCloseHead + aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] initHead (bobCardanoVk, _bobCardanoSk) <- keysFor Bob seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod - bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initAndCloseHead + bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initHead withHydraExplorer cardanoNode $ \explorer -> do headExplorerSees explorer "HeadInitTx" aliceHeadId - headExplorerSees explorer "HeadCloseTx" aliceHeadId headExplorerSees explorer "HeadInitTx" bobHeadId - headExplorerSees explorer "HeadCloseTx" aliceHeadId it "can query for all hydra heads observed" $ failAfter 60 $ diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 920c3cf0654..81d3742f25b 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -24,6 +24,7 @@ import Network.Wai ( responseLBS, ) import Network.Wai.Handler.Warp qualified as Warp +import System.Environment (withArgs) type ExplorerState = Map ChainPoint [(TxId, HeadObservation)] @@ -36,8 +37,10 @@ main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do explorerState <- newTVarIO (mempty :: ExplorerState) + args <- getArgs race - (Hydra.ChainObserver.main (observerHandler explorerState)) + -- FIXME: this is going to be problematic on mainnet. + (withArgs (args <> ["--start-chain-from", "0"]) $ Hydra.ChainObserver.main (observerHandler explorerState)) ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) *> Warp.runSettings (settings tracer) (httpApp tracer explorerState) ) From 69a00e46eb1ddc17f8e89c3b5be23b359624b093 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 12 Jan 2024 10:05:09 +0100 Subject: [PATCH 16/58] Enhance e2e spec over api --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 7 +++---- hydra-explorer/src/Hydra/Explorer.hs | 2 +- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index ca62f18b7d7..7ab1f8467f6 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -10,7 +10,7 @@ import Hydra.Prelude hiding (get) import Test.Hydra.Prelude import CardanoClient (NodeLog, RunningNode (..), submitTx) -import CardanoNode (withCardanoNodeDevnet) +import CardanoNode (unsafeDecodeJson, withCardanoNodeDevnet) import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) import Control.Exception (IOException) import Control.Lens ((^?)) @@ -22,7 +22,6 @@ import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile) import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod) import Hydra.Cluster.Util (chainConfigFor, keysFor) -import Hydra.HeadId (HeadId (..)) import Hydra.Logging (showLogsOnFailure) import HydraNode (HydraNodeLog, input, output, requestCommitTx, send, waitFor, waitMatch, withHydraNode) import Network.HTTP.Client qualified as HTTPClient @@ -132,8 +131,8 @@ spec = do response <- HTTPClient.httpLbs request manager HTTPClient.responseStatus response `shouldBe` status200 print (HTTPClient.responseBody response) - let maybeOpenHeads = decode $ HTTPClient.responseBody response :: Maybe [HeadId] - maybeOpenHeads `shouldBe` Just [UnsafeHeadId $ encodeUtf8 headId] + allHeads <- unsafeDecodeJson . toStrict $ HTTPClient.responseBody response + allHeads `shouldBe` [headId] headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () headExplorerSees explorer txType headId = diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 81d3742f25b..f46dafd2575 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -71,7 +71,7 @@ httpApp tracer explorerState req send = do case (requestMethod req, pathInfo req) of ("HEAD", _) -> send $ responseLBS status200 corsHeaders "" ("GET", []) -> send $ handleFile "index.html" - ("GET", ["heads"]) -> send $ responseLBS status200 corsHeaders "OK" + ("GET", ["heads"]) -> send $ responseLBS status200 corsHeaders "[]" -- FIXME: do proper file serving, this is dangerous ("GET", path) -> send $ handleFile $ toString $ mconcat $ List.intersperse "/" ("." : path) (_, _) -> send handleNotFound From 9befece2913a07e1739e272c7e76491cf34e713c Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 12 Jan 2024 10:27:25 +0100 Subject: [PATCH 17/58] Draft some plumbing in explorer HTTP server --- hydra-explorer/src/Hydra/Explorer.hs | 32 ++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index f46dafd2575..b98bb89da31 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -3,14 +3,18 @@ module Hydra.Explorer where import Hydra.ChainObserver qualified import Hydra.Prelude +-- XXX: Depending on hydra-node will be problematic to support versions +import Hydra.HeadId (HeadId) +import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) +import Hydra.Network (PortNumber) + import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO) +import Data.Aeson qualified as Aeson import Data.List qualified as List import Data.Map.Strict qualified as Map import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) import Hydra.Cardano.Api (ChainPoint, TxId) import Hydra.Chain.Direct.Tx (HeadObservation) -import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) -import Hydra.Network (PortNumber) import Network.HTTP.Types (status200) import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Status (status404, status500) @@ -37,12 +41,13 @@ main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do explorerState <- newTVarIO (mempty :: ExplorerState) + getHeadIds <- getHeadIdsReadModel explorerState args <- getArgs race -- FIXME: this is going to be problematic on mainnet. (withArgs (args <> ["--start-chain-from", "0"]) $ Hydra.ChainObserver.main (observerHandler explorerState)) ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) - *> Warp.runSettings (settings tracer) (httpApp tracer explorerState) + *> Warp.runSettings (settings tracer) (httpApp tracer getHeadIds) ) >>= \case Left{} -> error "Something went wrong" @@ -61,8 +66,15 @@ main = do putStrLn $ "Listening on: tcp/" <> show port ) -httpApp :: Tracer IO APIServerLog -> TVar IO ExplorerState -> Application -httpApp tracer explorerState req send = do + getHeadIdsReadModel :: TVar IO ExplorerState -> IO GetHeadIds + getHeadIdsReadModel tv = atomically $ do + currentState <- readTVar tv + pure $ pure [] + +type GetHeadIds = IO [HeadId] + +httpApp :: Tracer IO APIServerLog -> GetHeadIds -> Application +httpApp tracer getHeadIds req send = do traceWith tracer $ APIHTTPRequestReceived { method = Method $ requestMethod req @@ -71,11 +83,19 @@ httpApp tracer explorerState req send = do case (requestMethod req, pathInfo req) of ("HEAD", _) -> send $ responseLBS status200 corsHeaders "" ("GET", []) -> send $ handleFile "index.html" - ("GET", ["heads"]) -> send $ responseLBS status200 corsHeaders "[]" + ("GET", ["heads"]) -> handleGetHeads getHeadIds req send -- FIXME: do proper file serving, this is dangerous ("GET", path) -> send $ handleFile $ toString $ mconcat $ List.intersperse "/" ("." : path) (_, _) -> send handleNotFound +handleGetHeads :: + -- | Read model of all known head ids + GetHeadIds -> + Application +handleGetHeads getHeadIds _req send = do + headIds <- getHeadIds + send . responseLBS status200 corsHeaders $ Aeson.encode headIds + handleError :: Response handleError = responseLBS status500 corsHeaders "INVALID REQUEST" From d2b2dfe5a6ee712528ef5037448e351b192f8f45 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 12 Jan 2024 10:39:02 +0100 Subject: [PATCH 18/58] Make use of ObserverHandler during roll forward Simplify ObserverHandler and ExplorerState types. --- .../src/Hydra/ChainObserver.hs | 60 +++++++++++-------- hydra-explorer/src/Hydra/Explorer.hs | 27 ++++++--- 2 files changed, 54 insertions(+), 33 deletions(-) diff --git a/hydra-chain-observer/src/Hydra/ChainObserver.hs b/hydra-chain-observer/src/Hydra/ChainObserver.hs index 19d26a4cb5e..94a1a8d6554 100644 --- a/hydra-chain-observer/src/Hydra/ChainObserver.hs +++ b/hydra-chain-observer/src/Hydra/ChainObserver.hs @@ -53,12 +53,12 @@ import Ouroboros.Network.Protocol.ChainSync.Client ( ClientStNext (..), ) -type ObserverHandler = ChainPoint -> [(TxId, HeadObservation)] -> IO () +type ObserverHandler m = [HeadObservation] -> m () -defaultObserverHandler :: ObserverHandler -defaultObserverHandler = const . const $ pure () +defaultObserverHandler :: Applicative m => ObserverHandler m +defaultObserverHandler = const $ pure () -main :: ObserverHandler -> IO () +main :: ObserverHandler IO -> IO () main observerHandler = do Options{networkId, nodeSocket, startChainFrom} <- execParser hydraChainObserverOptions withTracer (Verbose "hydra-chain-observer") $ \tracer -> do @@ -70,7 +70,7 @@ main observerHandler = do traceWith tracer StartObservingFrom{chainPoint} connectToLocalNode (connectInfo nodeSocket networkId) - (clientProtocols tracer networkId chainPoint) + (clientProtocols tracer networkId chainPoint observerHandler) type ChainObserverLog :: Type data ChainObserverLog @@ -107,10 +107,11 @@ clientProtocols :: Tracer IO ChainObserverLog -> NetworkId -> ChainPoint -> + ObserverHandler IO -> LocalNodeClientProtocols BlockType ChainPoint ChainTip slot tx txid txerr query IO -clientProtocols tracer networkId startingPoint = +clientProtocols tracer networkId startingPoint observerHandler = LocalNodeClientProtocols - { localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint + { localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint observerHandler , localTxSubmissionClient = Nothing , localStateQueryClient = Nothing , localTxMonitoringClient = Nothing @@ -134,8 +135,9 @@ chainSyncClient :: Tracer m ChainObserverLog -> NetworkId -> ChainPoint -> + ObserverHandler m -> ChainSyncClient BlockType ChainPoint ChainTip m () -chainSyncClient tracer networkId startingPoint = +chainSyncClient tracer networkId startingPoint observerHandler = ChainSyncClient $ pure $ SendMsgFindIntersect [startingPoint] clientStIntersect @@ -159,9 +161,12 @@ chainSyncClient tracer networkId startingPoint = case blockInMode of BlockInMode _ (Block _header txs) BabbageEraInCardanoMode -> do let point = chainTipToChainPoint tip - traceWith tracer RollForward{point, receivedTxIds = getTxId . getTxBody <$> txs} - let (utxo', logs) = observeAll networkId utxo txs - forM_ logs (traceWith tracer) + let receivedTxIds = getTxId . getTxBody <$> txs + traceWith tracer RollForward{point, receivedTxIds} + let (utxo', observations) = observeAll networkId utxo txs + -- FIXME we should be exposing OnChainTx instead of working around NoHeadTx. + forM_ observations (maybe (pure ()) (traceWith tracer) . logObservation) + observerHandler observations pure $ clientStIdle utxo' _ -> pure $ clientStIdle utxo , recvMsgRollBackward = \point _tip -> ChainSyncClient $ do @@ -169,25 +174,30 @@ chainSyncClient tracer networkId startingPoint = pure $ clientStIdle utxo } -observeTx :: NetworkId -> UTxO -> Tx -> (UTxO, Maybe ChainObserverLog) + logObservation :: HeadObservation -> Maybe ChainObserverLog + logObservation = \case + NoHeadTx -> Nothing + Init InitObservation{headId} -> pure $ HeadInitTx{headId} + Commit CommitObservation{headId} -> pure $ HeadCommitTx{headId} + CollectCom CollectComObservation{headId} -> pure $ HeadCollectComTx{headId} + Close CloseObservation{headId} -> pure $ HeadCloseTx{headId} + Fanout FanoutObservation{headId} -> pure $ HeadFanoutTx{headId} + Abort AbortObservation{headId} -> pure $ HeadAbortTx{headId} + Contest ContestObservation{headId} -> pure $ HeadContestTx{headId} + +observeTx :: NetworkId -> UTxO -> Tx -> (UTxO, Maybe HeadObservation) observeTx networkId utxo tx = let utxo' = adjustUTxO tx utxo in case observeHeadTx networkId utxo tx of NoHeadTx -> (utxo, Nothing) - Init InitObservation{headId} -> (utxo', pure $ HeadInitTx{headId}) - Commit CommitObservation{headId} -> (utxo', pure $ HeadCommitTx{headId}) - CollectCom CollectComObservation{headId} -> (utxo', pure $ HeadCollectComTx{headId}) - Close CloseObservation{headId} -> (utxo', pure $ HeadCloseTx{headId}) - Fanout FanoutObservation{headId} -> (utxo', pure $ HeadFanoutTx{headId}) - Abort AbortObservation{headId} -> (utxo', pure $ HeadAbortTx{headId}) - Contest ContestObservation{headId} -> (utxo', pure $ HeadContestTx{headId}) - -observeAll :: NetworkId -> UTxO -> [Tx] -> (UTxO, [ChainObserverLog]) + observation -> (utxo', pure observation) + +observeAll :: NetworkId -> UTxO -> [Tx] -> (UTxO, [HeadObservation]) observeAll networkId utxo txs = second reverse $ foldr go (utxo, []) txs where - go :: Tx -> (UTxO, [ChainObserverLog]) -> (UTxO, [ChainObserverLog]) - go tx (utxo'', logs) = + go :: Tx -> (UTxO, [HeadObservation]) -> (UTxO, [HeadObservation]) + go tx (utxo'', observations) = case observeTx networkId utxo'' tx of - (utxo', Nothing) -> (utxo', logs) - (utxo', Just logEntry) -> (utxo', logEntry : logs) + (utxo', Nothing) -> (utxo', observations) + (utxo', Just observation) -> (utxo', observation : observations) diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index b98bb89da31..58e870e4c14 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -11,10 +11,8 @@ import Hydra.Network (PortNumber) import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO) import Data.Aeson qualified as Aeson import Data.List qualified as List -import Data.Map.Strict qualified as Map import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) -import Hydra.Cardano.Api (ChainPoint, TxId) -import Hydra.Chain.Direct.Tx (HeadObservation) +import Hydra.Chain.Direct.Tx (AbortObservation (..), CloseObservation (..), CollectComObservation (..), CommitObservation (..), ContestObservation (..), FanoutObservation (..), HeadObservation (..), InitObservation (..)) import Network.HTTP.Types (status200) import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Status (status404, status500) @@ -30,12 +28,12 @@ import Network.Wai ( import Network.Wai.Handler.Warp qualified as Warp import System.Environment (withArgs) -type ExplorerState = Map ChainPoint [(TxId, HeadObservation)] +type ExplorerState = [HeadObservation] -observerHandler :: TVar IO ExplorerState -> ChainPoint -> [(TxId, HeadObservation)] -> IO () -observerHandler explorerState point observations = +observerHandler :: TVar IO ExplorerState -> ExplorerState -> IO () +observerHandler explorerState observations = atomically $ - modifyTVar' explorerState (Map.insert point observations) + modifyTVar' explorerState (<> observations) main :: IO () main = do @@ -69,7 +67,20 @@ main = do getHeadIdsReadModel :: TVar IO ExplorerState -> IO GetHeadIds getHeadIdsReadModel tv = atomically $ do currentState <- readTVar tv - pure $ pure [] + let headIds = + mapMaybe + ( \case + NoHeadTx -> Nothing + Init InitObservation{headId} -> Just headId + Abort AbortObservation{headId} -> Just headId + Commit CommitObservation{headId} -> Just headId + CollectCom CollectComObservation{headId} -> Just headId + Close CloseObservation{headId} -> Just headId + Contest ContestObservation{headId} -> Just headId + Fanout FanoutObservation{headId} -> Just headId + ) + currentState + pure $ pure headIds type GetHeadIds = IO [HeadId] From c2a59be2c964e89e8e74fb11a56d9fe63bc665bf Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 12 Jan 2024 11:30:40 +0100 Subject: [PATCH 19/58] Fix GetHeadIds read model We must access the TVar in the actual GetHeadIds IO action instead only when setting it up. --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 1 - hydra-explorer/src/Hydra/Explorer.hs | 35 ++++++++++---------- 2 files changed, 17 insertions(+), 19 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 7ab1f8467f6..375a6c25b3a 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -130,7 +130,6 @@ spec = do } response <- HTTPClient.httpLbs request manager HTTPClient.responseStatus response `shouldBe` status200 - print (HTTPClient.responseBody response) allHeads <- unsafeDecodeJson . toStrict $ HTTPClient.responseBody response allHeads `shouldBe` [headId] diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 58e870e4c14..3beeeab17ba 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -31,7 +31,7 @@ import System.Environment (withArgs) type ExplorerState = [HeadObservation] observerHandler :: TVar IO ExplorerState -> ExplorerState -> IO () -observerHandler explorerState observations = +observerHandler explorerState observations = do atomically $ modifyTVar' explorerState (<> observations) @@ -39,7 +39,7 @@ main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do explorerState <- newTVarIO (mempty :: ExplorerState) - getHeadIds <- getHeadIdsReadModel explorerState + let getHeadIds = readModelGetHeadIds explorerState args <- getArgs race -- FIXME: this is going to be problematic on mainnet. @@ -64,23 +64,22 @@ main = do putStrLn $ "Listening on: tcp/" <> show port ) - getHeadIdsReadModel :: TVar IO ExplorerState -> IO GetHeadIds - getHeadIdsReadModel tv = atomically $ do + readModelGetHeadIds :: TVar IO ExplorerState -> GetHeadIds + readModelGetHeadIds tv = atomically $ do currentState <- readTVar tv - let headIds = - mapMaybe - ( \case - NoHeadTx -> Nothing - Init InitObservation{headId} -> Just headId - Abort AbortObservation{headId} -> Just headId - Commit CommitObservation{headId} -> Just headId - CollectCom CollectComObservation{headId} -> Just headId - Close CloseObservation{headId} -> Just headId - Contest ContestObservation{headId} -> Just headId - Fanout FanoutObservation{headId} -> Just headId - ) - currentState - pure $ pure headIds + pure $ + mapMaybe + ( \case + NoHeadTx -> Nothing + Init InitObservation{headId} -> Just headId + Abort AbortObservation{headId} -> Just headId + Commit CommitObservation{headId} -> Just headId + CollectCom CollectComObservation{headId} -> Just headId + Close CloseObservation{headId} -> Just headId + Contest ContestObservation{headId} -> Just headId + Fanout FanoutObservation{headId} -> Just headId + ) + currentState type GetHeadIds = IO [HeadId] From 6dbc9dd490f6b66032730e35796d022a09792a1f Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Mon, 15 Jan 2024 18:00:18 +0400 Subject: [PATCH 20/58] Draft openapi --- .../json-schemas/hydra-explorer-api.yaml | 97 +++++++++++++++++++ 1 file changed, 97 insertions(+) create mode 100644 hydra-explorer/json-schemas/hydra-explorer-api.yaml diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml new file mode 100644 index 00000000000..8332733f361 --- /dev/null +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -0,0 +1,97 @@ +openapi: 3.0.0 +info: + title: Head Explorer API + version: 1.0.0 +paths: + /heads: + get: + summary: Get a list of head states + responses: + '200': + description: Successful response + content: + application/json: + schema: + type: array + items: + $ref: '#/components/schemas/HeadState' + /heads/{headId}: + get: + summary: Get head by ID + parameters: + - in: path + name: headId + required: true + schema: + $ref: '#/components/schemas/HeadId' + responses: + '200': + description: Successful response + content: + application/json: + schema: + $ref: '#/components/schemas/HeadState' + +components: + schemas: + OnChainId: + type: string + description: | + A on-chain identifier for a Head participant, hex-encoded as 28 bytes string. + # "$ref": "cardano.json#/definitions/Digest" + # "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Digest" + Commit: + type: object + properties: + txIn: + $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/TransactionOutputReference" + txOut: + $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/TransactionOutput" + HeadMember: + type: object + properties: + party: + $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/VerificationKey" + onChainId: + $ref: '#/components/schemas/OnChainId' + # "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Digest" + commits: + type: array + items: + $ref: '#/components/schemas/Commit' + HeadStatus: + type: string + enum: + - Initializing + - Aborted + - Open + - Closed + - FanoutPossible + - Finalized + ContestationPeriod: + type: number + description: | + A contestation duration in seconds. + example: 60 + HeadId: + type: string + description: | + A unique identifier for a Head, represented by a hex-encoded 16 bytes string. + # contentEncoding: base16 + example: + "820082582089ff4f3ff4a6052ec9d073" + HeadState: + type: object + properties: + headId: + $ref: '#/components/schemas/HeadId' + seedTxIn: + $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/TransactionOutputReference" + status: + $ref: '#/components/schemas/HeadStatus' + contestationPeriod: + $ref: '#/components/schemas/ContestationPeriod' + members: + type: array + items: + $ref: '#/components/schemas/HeadMember' \ No newline at end of file From 448d62a4f2e9b7bf93d819de2f38cb50a9d332d7 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Mon, 15 Jan 2024 19:51:34 +0400 Subject: [PATCH 21/58] Introduce ipc server on chain-observer Remove the need to pass a handler to the main fn. --- hydra-chain-observer/exe/Main.hs | 3 +- .../hydra-chain-observer.cabal | 5 +- .../src/Hydra/ChainObserver.hs | 98 ++++++++++++++++--- .../src/Hydra/ChainObserver/Options.hs | 7 ++ .../test/Hydra/ChainObserverSpec.hs | 17 ++-- hydra-cluster/test/Test/ChainObserverSpec.hs | 2 + hydra-explorer/src/Hydra/Explorer.hs | 16 +-- 7 files changed, 118 insertions(+), 30 deletions(-) diff --git a/hydra-chain-observer/exe/Main.hs b/hydra-chain-observer/exe/Main.hs index 2450e080137..fcc93aed584 100644 --- a/hydra-chain-observer/exe/Main.hs +++ b/hydra-chain-observer/exe/Main.hs @@ -1,8 +1,7 @@ module Main where -import Hydra.ChainObserver (defaultObserverHandler) import Hydra.ChainObserver qualified import Hydra.Prelude main :: IO () -main = Hydra.ChainObserver.main defaultObserverHandler +main = Hydra.ChainObserver.main diff --git a/hydra-chain-observer/hydra-chain-observer.cabal b/hydra-chain-observer/hydra-chain-observer.cabal index 752a16d3473..0d00af247c4 100644 --- a/hydra-chain-observer/hydra-chain-observer.cabal +++ b/hydra-chain-observer/hydra-chain-observer.cabal @@ -16,6 +16,7 @@ source-repository head common project-config default-language: GHC2021 default-extensions: + NoImplicitPrelude BangPatterns BinaryLiterals ConstraintKinds @@ -41,7 +42,6 @@ common project-config MultiParamTypeClasses MultiWayIf NamedFieldPuns - NoImplicitPrelude NumericUnderscores OverloadedStrings PartialTypeSignatures @@ -64,10 +64,13 @@ library hs-source-dirs: src ghc-options: -haddock build-depends: + , base , hydra-cardano-api , hydra-node , hydra-plutus , hydra-prelude + , io-classes + , network , optparse-applicative , ouroboros-network-protocols diff --git a/hydra-chain-observer/src/Hydra/ChainObserver.hs b/hydra-chain-observer/src/Hydra/ChainObserver.hs index 94a1a8d6554..029b6dce2a4 100644 --- a/hydra-chain-observer/src/Hydra/ChainObserver.hs +++ b/hydra-chain-observer/src/Hydra/ChainObserver.hs @@ -4,6 +4,9 @@ module Hydra.ChainObserver where import Hydra.Prelude +import Control.Concurrent (forkFinally) +import Control.Concurrent.Class.MonadSTM (modifyTVar') +import Control.Exception () import Hydra.Cardano.Api ( Block (..), BlockInMode (..), @@ -45,6 +48,24 @@ import Hydra.Contract qualified as Contract import Hydra.HeadId (HeadId (..)) import Hydra.Ledger.Cardano (adjustUTxO) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) +import Hydra.Network (Host (..)) +import Hydra.Node.EventQueue (EventQueue (..), Queued (..), createEventQueue) +import Network.Socket ( + AddrInfo (..), + SocketOption (..), + SocketType (..), + accept, + bind, + close, + defaultHints, + defaultProtocol, + getAddrInfo, + listen, + setSocketOption, + socket, + socketToHandle, + withSocketsDo, + ) import Options.Applicative (execParser) import Ouroboros.Network.Protocol.ChainSync.Client ( ChainSyncClient (..), @@ -52,15 +73,59 @@ import Ouroboros.Network.Protocol.ChainSync.Client ( ClientStIntersect (..), ClientStNext (..), ) +import System.IO (hClose, hPrint) type ObserverHandler m = [HeadObservation] -> m () -defaultObserverHandler :: Applicative m => ObserverHandler m -defaultObserverHandler = const $ pure () +type ObserverState = [HeadObservation] + +observerHandler :: TVar IO ObserverState -> ObserverState -> IO () +observerHandler observerState observations = + atomically $ + modifyTVar' observerState (<> observations) + +runIPCServer :: Host -> EventQueue IO ObserverState -> IO () +runIPCServer Host{hostname, port} eq = withSocketsDo $ do + -- Create a TCP socket + bracket + openTCPListener + close + ( \sock -> do + putStrLn $ "Listening on port " ++ show port + forever $ do + -- Accept incoming connection + (conn, _) <- accept sock + -- Fork a new thread to handle the connection + forkFinally + (handleClient conn) + ( \_ -> close conn + ) + ) + where + openTCPListener = do + is <- getAddrInfo (Just defaultHints) (Just $ toString hostname) (Just $ show port) + addr <- case is of + (inf : _) -> pure inf + _ -> die "getAdrrInfo failed" + sock <- socket (addrFamily addr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (addrAddress addr) + listen sock 5 + return sock + + handleClient conn = do + hdl <- socketToHandle conn ReadWriteMode + hSetBuffering hdl LineBuffering + putStrLn "Client connected" + pushObservation hdl `finally` hClose hdl + + pushObservation hdl = forever $ do + Queued{queuedEvent} <- nextEvent eq + hPrint hdl queuedEvent -main :: ObserverHandler IO -> IO () -main observerHandler = do - Options{networkId, nodeSocket, startChainFrom} <- execParser hydraChainObserverOptions +main :: IO () +main = do + Options{networkId, nodeSocket, host, port, startChainFrom} <- execParser hydraChainObserverOptions withTracer (Verbose "hydra-chain-observer") $ \tracer -> do traceWith tracer KnownScripts{scriptInfo = Contract.scriptInfo} traceWith tracer ConnectingToNode{nodeSocket, networkId} @@ -68,9 +133,18 @@ main observerHandler = do Nothing -> queryTip networkId nodeSocket Just x -> pure x traceWith tracer StartObservingFrom{chainPoint} - connectToLocalNode - (connectInfo nodeSocket networkId) - (clientProtocols tracer networkId chainPoint observerHandler) + eq@EventQueue{putEvent} <- createEventQueue + race + ( runIPCServer Host{hostname = show host, port} eq + `catch` \(e :: SomeException) -> putStrLn $ "Exception: " ++ show e + ) + ( connectToLocalNode + (connectInfo nodeSocket networkId) + (clientProtocols tracer networkId chainPoint putEvent) + ) + >>= \case + Left{} -> error "Something went wrong: " + Right a -> pure a type ChainObserverLog :: Type data ChainObserverLog @@ -109,9 +183,9 @@ clientProtocols :: ChainPoint -> ObserverHandler IO -> LocalNodeClientProtocols BlockType ChainPoint ChainTip slot tx txid txerr query IO -clientProtocols tracer networkId startingPoint observerHandler = +clientProtocols tracer networkId startingPoint observerHandle = LocalNodeClientProtocols - { localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint observerHandler + { localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint observerHandle , localTxSubmissionClient = Nothing , localStateQueryClient = Nothing , localTxMonitoringClient = Nothing @@ -137,7 +211,7 @@ chainSyncClient :: ChainPoint -> ObserverHandler m -> ChainSyncClient BlockType ChainPoint ChainTip m () -chainSyncClient tracer networkId startingPoint observerHandler = +chainSyncClient tracer networkId startingPoint observerHandle = ChainSyncClient $ pure $ SendMsgFindIntersect [startingPoint] clientStIntersect @@ -166,7 +240,7 @@ chainSyncClient tracer networkId startingPoint observerHandler = let (utxo', observations) = observeAll networkId utxo txs -- FIXME we should be exposing OnChainTx instead of working around NoHeadTx. forM_ observations (maybe (pure ()) (traceWith tracer) . logObservation) - observerHandler observations + observerHandle observations pure $ clientStIdle utxo' _ -> pure $ clientStIdle utxo , recvMsgRollBackward = \point _tip -> ChainSyncClient $ do diff --git a/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs b/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs index 6d9ed65f20e..cf51187edfd 100644 --- a/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs +++ b/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs @@ -3,9 +3,12 @@ module Hydra.ChainObserver.Options where import Hydra.Prelude import Hydra.Cardano.Api (ChainPoint, NetworkId, SocketPath) +import Hydra.Network (IP, PortNumber) import Hydra.Options ( + hostParser, networkIdParser, nodeSocketParser, + portParser, startChainFromParser, ) import Options.Applicative (Parser, ParserInfo, fullDesc, header, helper, info, progDesc) @@ -14,6 +17,8 @@ type Options :: Type data Options = Options { networkId :: NetworkId , nodeSocket :: SocketPath + , host :: IP + , port :: PortNumber , startChainFrom :: Maybe ChainPoint -- ^ Point at which to start following the chain. } @@ -24,6 +29,8 @@ optionsParser = Options <$> networkIdParser <*> nodeSocketParser + <*> hostParser + <*> portParser <*> optional startChainFromParser hydraChainObserverOptions :: ParserInfo Options diff --git a/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs b/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs index a9902743b76..f95496aaf28 100644 --- a/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs +++ b/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs @@ -6,7 +6,8 @@ import Test.Hydra.Prelude import Hydra.Chain.Direct.Fixture (testNetworkId) import Hydra.Chain.Direct.State (HasKnownUTxO (getKnownUTxO), genChainStateWithTx) import Hydra.Chain.Direct.State qualified as Transition -import Hydra.ChainObserver (ChainObserverLog (..), observeAll, observeTx) +import Hydra.Chain.Direct.Tx (HeadObservation (..)) +import Hydra.ChainObserver (observeAll, observeTx) import Hydra.Ledger.Cardano (genSequenceOfSimplePaymentTransactions) import Test.QuickCheck (counterexample, forAll, forAllBlind, property, (=/=), (===)) import Test.QuickCheck.Property (checkCoverage) @@ -21,13 +22,13 @@ spec = counterexample (show transition) $ let utxo = getKnownUTxO st in case snd $ observeTx testNetworkId utxo tx of - Just (HeadInitTx{}) -> transition === Transition.Init - Just (HeadCommitTx{}) -> transition === Transition.Commit - Just (HeadCollectComTx{}) -> transition === Transition.Collect - Just (HeadAbortTx{}) -> transition === Transition.Abort - Just (HeadCloseTx{}) -> transition === Transition.Close - Just (HeadContestTx{}) -> transition === Transition.Contest - Just (HeadFanoutTx{}) -> transition === Transition.Fanout + Just (Init{}) -> transition === Transition.Init + Just (Abort{}) -> transition === Transition.Abort + Just (Commit{}) -> transition === Transition.Commit + Just (CollectCom{}) -> transition === Transition.Collect + Just (Close{}) -> transition === Transition.Close + Just (Contest{}) -> transition === Transition.Contest + Just (Fanout{}) -> transition === Transition.Fanout _ -> property False prop "Updates UTxO state given transaction part of Head lifecycle" $ diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index f066808f50b..b9a9bceed82 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -139,6 +139,8 @@ withChainObserver cardanoNode action = proc "hydra-chain-observer" $ ["--node-socket", unFile nodeSocket] + <> ["--host", "127.0.0.1"] + <> ["--port", "8888"] <> case networkId of Mainnet -> ["--mainnet"] Testnet (NetworkMagic magic) -> ["--testnet-magic", show magic] diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 3beeeab17ba..fd485762d75 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -8,7 +8,7 @@ import Hydra.HeadId (HeadId) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) import Hydra.Network (PortNumber) -import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO) +import Control.Concurrent.Class.MonadSTM (newTVarIO) import Data.Aeson qualified as Aeson import Data.List qualified as List import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) @@ -30,11 +30,6 @@ import System.Environment (withArgs) type ExplorerState = [HeadObservation] -observerHandler :: TVar IO ExplorerState -> ExplorerState -> IO () -observerHandler explorerState observations = do - atomically $ - modifyTVar' explorerState (<> observations) - main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do @@ -43,7 +38,14 @@ main = do args <- getArgs race -- FIXME: this is going to be problematic on mainnet. - (withArgs (args <> ["--start-chain-from", "0"]) $ Hydra.ChainObserver.main (observerHandler explorerState)) + ( withArgs + ( args + <> ["--start-chain-from", "0"] + <> ["--host", "127.0.0.1"] + <> ["--port", "8888"] + ) + Hydra.ChainObserver.main + ) ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) *> Warp.runSettings (settings tracer) (httpApp tracer getHeadIds) ) From 20cc1879a75e86affce612023b8bfa4f0d092e75 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 16 Jan 2024 20:48:41 +0400 Subject: [PATCH 22/58] Revert "Introduce ipc server on chain-observer" This reverts commit 1f21d9556db9b258d46c8b7164aa722a06a6c2ee. --- hydra-chain-observer/exe/Main.hs | 3 +- .../hydra-chain-observer.cabal | 5 +- .../src/Hydra/ChainObserver.hs | 98 +++---------------- .../src/Hydra/ChainObserver/Options.hs | 7 -- .../test/Hydra/ChainObserverSpec.hs | 17 ++-- hydra-cluster/test/Test/ChainObserverSpec.hs | 2 - hydra-explorer/src/Hydra/Explorer.hs | 16 ++- 7 files changed, 30 insertions(+), 118 deletions(-) diff --git a/hydra-chain-observer/exe/Main.hs b/hydra-chain-observer/exe/Main.hs index fcc93aed584..2450e080137 100644 --- a/hydra-chain-observer/exe/Main.hs +++ b/hydra-chain-observer/exe/Main.hs @@ -1,7 +1,8 @@ module Main where +import Hydra.ChainObserver (defaultObserverHandler) import Hydra.ChainObserver qualified import Hydra.Prelude main :: IO () -main = Hydra.ChainObserver.main +main = Hydra.ChainObserver.main defaultObserverHandler diff --git a/hydra-chain-observer/hydra-chain-observer.cabal b/hydra-chain-observer/hydra-chain-observer.cabal index 0d00af247c4..752a16d3473 100644 --- a/hydra-chain-observer/hydra-chain-observer.cabal +++ b/hydra-chain-observer/hydra-chain-observer.cabal @@ -16,7 +16,6 @@ source-repository head common project-config default-language: GHC2021 default-extensions: - NoImplicitPrelude BangPatterns BinaryLiterals ConstraintKinds @@ -42,6 +41,7 @@ common project-config MultiParamTypeClasses MultiWayIf NamedFieldPuns + NoImplicitPrelude NumericUnderscores OverloadedStrings PartialTypeSignatures @@ -64,13 +64,10 @@ library hs-source-dirs: src ghc-options: -haddock build-depends: - , base , hydra-cardano-api , hydra-node , hydra-plutus , hydra-prelude - , io-classes - , network , optparse-applicative , ouroboros-network-protocols diff --git a/hydra-chain-observer/src/Hydra/ChainObserver.hs b/hydra-chain-observer/src/Hydra/ChainObserver.hs index 029b6dce2a4..94a1a8d6554 100644 --- a/hydra-chain-observer/src/Hydra/ChainObserver.hs +++ b/hydra-chain-observer/src/Hydra/ChainObserver.hs @@ -4,9 +4,6 @@ module Hydra.ChainObserver where import Hydra.Prelude -import Control.Concurrent (forkFinally) -import Control.Concurrent.Class.MonadSTM (modifyTVar') -import Control.Exception () import Hydra.Cardano.Api ( Block (..), BlockInMode (..), @@ -48,24 +45,6 @@ import Hydra.Contract qualified as Contract import Hydra.HeadId (HeadId (..)) import Hydra.Ledger.Cardano (adjustUTxO) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) -import Hydra.Network (Host (..)) -import Hydra.Node.EventQueue (EventQueue (..), Queued (..), createEventQueue) -import Network.Socket ( - AddrInfo (..), - SocketOption (..), - SocketType (..), - accept, - bind, - close, - defaultHints, - defaultProtocol, - getAddrInfo, - listen, - setSocketOption, - socket, - socketToHandle, - withSocketsDo, - ) import Options.Applicative (execParser) import Ouroboros.Network.Protocol.ChainSync.Client ( ChainSyncClient (..), @@ -73,59 +52,15 @@ import Ouroboros.Network.Protocol.ChainSync.Client ( ClientStIntersect (..), ClientStNext (..), ) -import System.IO (hClose, hPrint) type ObserverHandler m = [HeadObservation] -> m () -type ObserverState = [HeadObservation] - -observerHandler :: TVar IO ObserverState -> ObserverState -> IO () -observerHandler observerState observations = - atomically $ - modifyTVar' observerState (<> observations) - -runIPCServer :: Host -> EventQueue IO ObserverState -> IO () -runIPCServer Host{hostname, port} eq = withSocketsDo $ do - -- Create a TCP socket - bracket - openTCPListener - close - ( \sock -> do - putStrLn $ "Listening on port " ++ show port - forever $ do - -- Accept incoming connection - (conn, _) <- accept sock - -- Fork a new thread to handle the connection - forkFinally - (handleClient conn) - ( \_ -> close conn - ) - ) - where - openTCPListener = do - is <- getAddrInfo (Just defaultHints) (Just $ toString hostname) (Just $ show port) - addr <- case is of - (inf : _) -> pure inf - _ -> die "getAdrrInfo failed" - sock <- socket (addrFamily addr) Stream defaultProtocol - setSocketOption sock ReuseAddr 1 - bind sock (addrAddress addr) - listen sock 5 - return sock - - handleClient conn = do - hdl <- socketToHandle conn ReadWriteMode - hSetBuffering hdl LineBuffering - putStrLn "Client connected" - pushObservation hdl `finally` hClose hdl - - pushObservation hdl = forever $ do - Queued{queuedEvent} <- nextEvent eq - hPrint hdl queuedEvent +defaultObserverHandler :: Applicative m => ObserverHandler m +defaultObserverHandler = const $ pure () -main :: IO () -main = do - Options{networkId, nodeSocket, host, port, startChainFrom} <- execParser hydraChainObserverOptions +main :: ObserverHandler IO -> IO () +main observerHandler = do + Options{networkId, nodeSocket, startChainFrom} <- execParser hydraChainObserverOptions withTracer (Verbose "hydra-chain-observer") $ \tracer -> do traceWith tracer KnownScripts{scriptInfo = Contract.scriptInfo} traceWith tracer ConnectingToNode{nodeSocket, networkId} @@ -133,18 +68,9 @@ main = do Nothing -> queryTip networkId nodeSocket Just x -> pure x traceWith tracer StartObservingFrom{chainPoint} - eq@EventQueue{putEvent} <- createEventQueue - race - ( runIPCServer Host{hostname = show host, port} eq - `catch` \(e :: SomeException) -> putStrLn $ "Exception: " ++ show e - ) - ( connectToLocalNode - (connectInfo nodeSocket networkId) - (clientProtocols tracer networkId chainPoint putEvent) - ) - >>= \case - Left{} -> error "Something went wrong: " - Right a -> pure a + connectToLocalNode + (connectInfo nodeSocket networkId) + (clientProtocols tracer networkId chainPoint observerHandler) type ChainObserverLog :: Type data ChainObserverLog @@ -183,9 +109,9 @@ clientProtocols :: ChainPoint -> ObserverHandler IO -> LocalNodeClientProtocols BlockType ChainPoint ChainTip slot tx txid txerr query IO -clientProtocols tracer networkId startingPoint observerHandle = +clientProtocols tracer networkId startingPoint observerHandler = LocalNodeClientProtocols - { localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint observerHandle + { localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint observerHandler , localTxSubmissionClient = Nothing , localStateQueryClient = Nothing , localTxMonitoringClient = Nothing @@ -211,7 +137,7 @@ chainSyncClient :: ChainPoint -> ObserverHandler m -> ChainSyncClient BlockType ChainPoint ChainTip m () -chainSyncClient tracer networkId startingPoint observerHandle = +chainSyncClient tracer networkId startingPoint observerHandler = ChainSyncClient $ pure $ SendMsgFindIntersect [startingPoint] clientStIntersect @@ -240,7 +166,7 @@ chainSyncClient tracer networkId startingPoint observerHandle = let (utxo', observations) = observeAll networkId utxo txs -- FIXME we should be exposing OnChainTx instead of working around NoHeadTx. forM_ observations (maybe (pure ()) (traceWith tracer) . logObservation) - observerHandle observations + observerHandler observations pure $ clientStIdle utxo' _ -> pure $ clientStIdle utxo , recvMsgRollBackward = \point _tip -> ChainSyncClient $ do diff --git a/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs b/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs index cf51187edfd..6d9ed65f20e 100644 --- a/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs +++ b/hydra-chain-observer/src/Hydra/ChainObserver/Options.hs @@ -3,12 +3,9 @@ module Hydra.ChainObserver.Options where import Hydra.Prelude import Hydra.Cardano.Api (ChainPoint, NetworkId, SocketPath) -import Hydra.Network (IP, PortNumber) import Hydra.Options ( - hostParser, networkIdParser, nodeSocketParser, - portParser, startChainFromParser, ) import Options.Applicative (Parser, ParserInfo, fullDesc, header, helper, info, progDesc) @@ -17,8 +14,6 @@ type Options :: Type data Options = Options { networkId :: NetworkId , nodeSocket :: SocketPath - , host :: IP - , port :: PortNumber , startChainFrom :: Maybe ChainPoint -- ^ Point at which to start following the chain. } @@ -29,8 +24,6 @@ optionsParser = Options <$> networkIdParser <*> nodeSocketParser - <*> hostParser - <*> portParser <*> optional startChainFromParser hydraChainObserverOptions :: ParserInfo Options diff --git a/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs b/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs index f95496aaf28..a9902743b76 100644 --- a/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs +++ b/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs @@ -6,8 +6,7 @@ import Test.Hydra.Prelude import Hydra.Chain.Direct.Fixture (testNetworkId) import Hydra.Chain.Direct.State (HasKnownUTxO (getKnownUTxO), genChainStateWithTx) import Hydra.Chain.Direct.State qualified as Transition -import Hydra.Chain.Direct.Tx (HeadObservation (..)) -import Hydra.ChainObserver (observeAll, observeTx) +import Hydra.ChainObserver (ChainObserverLog (..), observeAll, observeTx) import Hydra.Ledger.Cardano (genSequenceOfSimplePaymentTransactions) import Test.QuickCheck (counterexample, forAll, forAllBlind, property, (=/=), (===)) import Test.QuickCheck.Property (checkCoverage) @@ -22,13 +21,13 @@ spec = counterexample (show transition) $ let utxo = getKnownUTxO st in case snd $ observeTx testNetworkId utxo tx of - Just (Init{}) -> transition === Transition.Init - Just (Abort{}) -> transition === Transition.Abort - Just (Commit{}) -> transition === Transition.Commit - Just (CollectCom{}) -> transition === Transition.Collect - Just (Close{}) -> transition === Transition.Close - Just (Contest{}) -> transition === Transition.Contest - Just (Fanout{}) -> transition === Transition.Fanout + Just (HeadInitTx{}) -> transition === Transition.Init + Just (HeadCommitTx{}) -> transition === Transition.Commit + Just (HeadCollectComTx{}) -> transition === Transition.Collect + Just (HeadAbortTx{}) -> transition === Transition.Abort + Just (HeadCloseTx{}) -> transition === Transition.Close + Just (HeadContestTx{}) -> transition === Transition.Contest + Just (HeadFanoutTx{}) -> transition === Transition.Fanout _ -> property False prop "Updates UTxO state given transaction part of Head lifecycle" $ diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index b9a9bceed82..f066808f50b 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -139,8 +139,6 @@ withChainObserver cardanoNode action = proc "hydra-chain-observer" $ ["--node-socket", unFile nodeSocket] - <> ["--host", "127.0.0.1"] - <> ["--port", "8888"] <> case networkId of Mainnet -> ["--mainnet"] Testnet (NetworkMagic magic) -> ["--testnet-magic", show magic] diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index fd485762d75..3beeeab17ba 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -8,7 +8,7 @@ import Hydra.HeadId (HeadId) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) import Hydra.Network (PortNumber) -import Control.Concurrent.Class.MonadSTM (newTVarIO) +import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO) import Data.Aeson qualified as Aeson import Data.List qualified as List import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) @@ -30,6 +30,11 @@ import System.Environment (withArgs) type ExplorerState = [HeadObservation] +observerHandler :: TVar IO ExplorerState -> ExplorerState -> IO () +observerHandler explorerState observations = do + atomically $ + modifyTVar' explorerState (<> observations) + main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do @@ -38,14 +43,7 @@ main = do args <- getArgs race -- FIXME: this is going to be problematic on mainnet. - ( withArgs - ( args - <> ["--start-chain-from", "0"] - <> ["--host", "127.0.0.1"] - <> ["--port", "8888"] - ) - Hydra.ChainObserver.main - ) + (withArgs (args <> ["--start-chain-from", "0"]) $ Hydra.ChainObserver.main (observerHandler explorerState)) ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) *> Warp.runSettings (settings tracer) (httpApp tracer getHeadIds) ) From adcc8fe2c16c8ea9e312ef749c526c8432955810 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 18 Jan 2024 11:37:27 +0400 Subject: [PATCH 23/58] Enhance explorer state to be an aggregation of head observations --- hydra-explorer/src/Hydra/Explorer.hs | 90 ++++++++++++++++++---------- 1 file changed, 60 insertions(+), 30 deletions(-) diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 3beeeab17ba..6667bc97608 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -8,11 +8,16 @@ import Hydra.HeadId (HeadId) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) import Hydra.Network (PortNumber) -import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO) +import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) import Data.Aeson qualified as Aeson import Data.List qualified as List import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) -import Hydra.Chain.Direct.Tx (AbortObservation (..), CloseObservation (..), CollectComObservation (..), CommitObservation (..), ContestObservation (..), FanoutObservation (..), HeadObservation (..), InitObservation (..)) +import Hydra.Cardano.Api (TxIn, TxOut) +import Hydra.Cardano.Api.Prelude (CtxUTxO) +import Hydra.Chain.Direct.Tx (HeadObservation (..)) +import Hydra.ContestationPeriod (ContestationPeriod) +import Hydra.OnChainId (OnChainId) +import Hydra.Party (Party) import Network.HTTP.Types (status200) import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Status (status404, status500) @@ -28,24 +33,63 @@ import Network.Wai ( import Network.Wai.Handler.Warp qualified as Warp import System.Environment (withArgs) -type ExplorerState = [HeadObservation] +data PartyCommit = PartyCommit + { txIn :: TxIn + , txOut :: TxOut CtxUTxO + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) -observerHandler :: TVar IO ExplorerState -> ExplorerState -> IO () +data HeadMember = HeadMember + { party :: Party + , onChainId :: OnChainId + , commits :: [PartyCommit] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data HeadStatus + = Initializing + | Aborted + | Open + | Closed + | FanoutPossible + | Finalized + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data HeadState = HeadState + { headId :: HeadId + , seedTxIn :: TxIn + , status :: HeadStatus + , contestationPeriod :: ContestationPeriod + , members :: [HeadMember] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +type ExplorerState = [HeadState] + +aggregateHeadObservations :: [HeadObservation] -> ExplorerState -> ExplorerState +aggregateHeadObservations = undefined + +observerHandler :: TVar IO ExplorerState -> [HeadObservation] -> IO () observerHandler explorerState observations = do atomically $ - modifyTVar' explorerState (<> observations) + modifyTVar' explorerState $ + aggregateHeadObservations observations main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do explorerState <- newTVarIO (mempty :: ExplorerState) - let getHeadIds = readModelGetHeadIds explorerState + let getHeads = readModelGetHeadIds explorerState args <- getArgs race -- FIXME: this is going to be problematic on mainnet. (withArgs (args <> ["--start-chain-from", "0"]) $ Hydra.ChainObserver.main (observerHandler explorerState)) ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) - *> Warp.runSettings (settings tracer) (httpApp tracer getHeadIds) + *> Warp.runSettings (settings tracer) (httpApp tracer getHeads) ) >>= \case Left{} -> error "Something went wrong" @@ -64,27 +108,13 @@ main = do putStrLn $ "Listening on: tcp/" <> show port ) - readModelGetHeadIds :: TVar IO ExplorerState -> GetHeadIds - readModelGetHeadIds tv = atomically $ do - currentState <- readTVar tv - pure $ - mapMaybe - ( \case - NoHeadTx -> Nothing - Init InitObservation{headId} -> Just headId - Abort AbortObservation{headId} -> Just headId - Commit CommitObservation{headId} -> Just headId - CollectCom CollectComObservation{headId} -> Just headId - Close CloseObservation{headId} -> Just headId - Contest ContestObservation{headId} -> Just headId - Fanout FanoutObservation{headId} -> Just headId - ) - currentState + readModelGetHeadIds :: TVar IO ExplorerState -> GetHeads + readModelGetHeadIds = readTVarIO -type GetHeadIds = IO [HeadId] +type GetHeads = IO [HeadState] -httpApp :: Tracer IO APIServerLog -> GetHeadIds -> Application -httpApp tracer getHeadIds req send = do +httpApp :: Tracer IO APIServerLog -> GetHeads -> Application +httpApp tracer getHeads req send = do traceWith tracer $ APIHTTPRequestReceived { method = Method $ requestMethod req @@ -93,17 +123,17 @@ httpApp tracer getHeadIds req send = do case (requestMethod req, pathInfo req) of ("HEAD", _) -> send $ responseLBS status200 corsHeaders "" ("GET", []) -> send $ handleFile "index.html" - ("GET", ["heads"]) -> handleGetHeads getHeadIds req send + ("GET", ["heads"]) -> handleGetHeads getHeads req send -- FIXME: do proper file serving, this is dangerous ("GET", path) -> send $ handleFile $ toString $ mconcat $ List.intersperse "/" ("." : path) (_, _) -> send handleNotFound handleGetHeads :: -- | Read model of all known head ids - GetHeadIds -> + GetHeads -> Application -handleGetHeads getHeadIds _req send = do - headIds <- getHeadIds +handleGetHeads getHeads _req send = do + headIds <- getHeads send . responseLBS status200 corsHeaders $ Aeson.encode headIds handleError :: Response From 580deafcf557aca874f96d1b94ec6b2d118b119b Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 18 Jan 2024 22:02:15 +0400 Subject: [PATCH 24/58] Aggregate observations into explorer state --- hydra-cluster/hydra-cluster.cabal | 1 + hydra-cluster/test/Test/HydraExplorerSpec.hs | 15 +- hydra-explorer/hydra-explorer.cabal | 4 +- .../json-schemas/hydra-explorer-api.yaml | 1 - hydra-explorer/src/Hydra/Explorer.hs | 56 +----- .../src/Hydra/Explorer/ExplorerState.hs | 185 ++++++++++++++++++ 6 files changed, 205 insertions(+), 57 deletions(-) create mode 100644 hydra-explorer/src/Hydra/Explorer/ExplorerState.hs diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index 4d9250ca66e..6c963dcbb36 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -175,6 +175,7 @@ test-suite tests , http-types , hydra-cardano-api , hydra-cluster + , hydra-explorer , hydra-node:{hydra-node, testlib} , hydra-prelude , hydra-test-utils diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 375a6c25b3a..ad3686c1bab 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -9,8 +9,8 @@ module Test.HydraExplorerSpec where import Hydra.Prelude hiding (get) import Test.Hydra.Prelude -import CardanoClient (NodeLog, RunningNode (..), submitTx) -import CardanoNode (unsafeDecodeJson, withCardanoNodeDevnet) +import CardanoClient (RunningNode (..), submitTx) +import CardanoNode (NodeLog, unsafeDecodeJson, withCardanoNodeDevnet) import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) import Control.Exception (IOException) import Control.Lens ((^?)) @@ -22,6 +22,8 @@ import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile) import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod) import Hydra.Cluster.Util (chainConfigFor, keysFor) +import Hydra.Explorer.ExplorerState (HeadState (..), HeadStatus (..)) +import Hydra.HeadId (HeadId (..)) import Hydra.Logging (showLogsOnFailure) import HydraNode (HydraNodeLog, input, output, requestCommitTx, send, waitFor, waitMatch, withHydraNode) import Network.HTTP.Client qualified as HTTPClient @@ -114,11 +116,11 @@ spec = do send hydraNode $ input "Init" [] - headId <- waitMatch 5 hydraNode $ \v -> do + aliceHeadId <- waitMatch 5 hydraNode $ \v -> do guard $ v ^? key "tag" == Just "HeadIsInitializing" v ^? key "headId" . _String - headExplorerSees explorer "HeadInitTx" headId + headExplorerSees explorer "HeadInitTx" aliceHeadId manager <- HTTPClient.newTlsManager let url = "http://127.0.0.1:9090/heads" @@ -131,7 +133,10 @@ spec = do response <- HTTPClient.httpLbs request manager HTTPClient.responseStatus response `shouldBe` status200 allHeads <- unsafeDecodeJson . toStrict $ HTTPClient.responseBody response - allHeads `shouldBe` [headId] + length allHeads `shouldBe` 1 + let [HeadState{headId = (UnsafeHeadId idBS), status}] = allHeads + aliceHeadId `shouldBe` decodeUtf8 idBS + status `shouldBe` Initializing headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () headExplorerSees explorer txType headId = diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index ee1c1fd75b7..4e7f40a42d4 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -57,7 +57,9 @@ library , wai , warp - exposed-modules: Hydra.Explorer + exposed-modules: + Hydra.Explorer + Hydra.Explorer.ExplorerState executable hydra-explorer import: project-config diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index 8332733f361..6759c9f4c28 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -66,7 +66,6 @@ components: - Aborted - Open - Closed - - FanoutPossible - Finalized ContestationPeriod: type: number diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 6667bc97608..c10495c0577 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -3,8 +3,6 @@ module Hydra.Explorer where import Hydra.ChainObserver qualified import Hydra.Prelude --- XXX: Depending on hydra-node will be problematic to support versions -import Hydra.HeadId (HeadId) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) import Hydra.Network (PortNumber) @@ -12,12 +10,10 @@ import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) import Data.Aeson qualified as Aeson import Data.List qualified as List import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) -import Hydra.Cardano.Api (TxIn, TxOut) -import Hydra.Cardano.Api.Prelude (CtxUTxO) -import Hydra.Chain.Direct.Tx (HeadObservation (..)) -import Hydra.ContestationPeriod (ContestationPeriod) -import Hydra.OnChainId (OnChainId) -import Hydra.Party (Party) +import Hydra.Chain.Direct.Tx ( + HeadObservation (..), + ) +import Hydra.Explorer.ExplorerState (ExplorerState, HeadState, aggregateHeadObservations) import Network.HTTP.Types (status200) import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Status (status404, status500) @@ -33,46 +29,6 @@ import Network.Wai ( import Network.Wai.Handler.Warp qualified as Warp import System.Environment (withArgs) -data PartyCommit = PartyCommit - { txIn :: TxIn - , txOut :: TxOut CtxUTxO - } - deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -data HeadMember = HeadMember - { party :: Party - , onChainId :: OnChainId - , commits :: [PartyCommit] - } - deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -data HeadStatus - = Initializing - | Aborted - | Open - | Closed - | FanoutPossible - | Finalized - deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -data HeadState = HeadState - { headId :: HeadId - , seedTxIn :: TxIn - , status :: HeadStatus - , contestationPeriod :: ContestationPeriod - , members :: [HeadMember] - } - deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -type ExplorerState = [HeadState] - -aggregateHeadObservations :: [HeadObservation] -> ExplorerState -> ExplorerState -aggregateHeadObservations = undefined - observerHandler :: TVar IO ExplorerState -> [HeadObservation] -> IO () observerHandler explorerState observations = do atomically $ @@ -133,8 +89,8 @@ handleGetHeads :: GetHeads -> Application handleGetHeads getHeads _req send = do - headIds <- getHeads - send . responseLBS status200 corsHeaders $ Aeson.encode headIds + heads <- getHeads + send . responseLBS status200 corsHeaders $ Aeson.encode heads handleError :: Response handleError = diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs new file mode 100644 index 00000000000..2bf7f09f267 --- /dev/null +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -0,0 +1,185 @@ +module Hydra.Explorer.ExplorerState where + +import Hydra.Prelude + +-- XXX: Depending on hydra-node will be problematic to support versions +import Hydra.HeadId (HeadId (..)) + +import Hydra.Cardano.Api (TxIn, TxOut) +import Hydra.Cardano.Api.Prelude (CtxUTxO) +import Hydra.Chain.Direct.Tx ( + AbortObservation (..), + CloseObservation (..), + CollectComObservation (..), + CommitObservation (..), + ContestObservation (..), + FanoutObservation (..), + HeadObservation (..), + InitObservation (..), + ) +import Hydra.ContestationPeriod (ContestationPeriod) +import Hydra.OnChainId (OnChainId) +import Hydra.Party (Party) + +data PartyCommit = PartyCommit + { txIn :: TxIn + , txOut :: TxOut CtxUTxO + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data HeadMember = HeadMember + { party :: Party + , onChainId :: OnChainId + , commits :: [PartyCommit] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data HeadStatus + = Initializing + | Aborted + | Open + | Closed + | Finalized + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data HeadState = HeadState + { headId :: HeadId + , seedTxIn :: TxIn + , status :: HeadStatus + , contestationPeriod :: ContestationPeriod + , members :: [HeadMember] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +type ExplorerState = [HeadState] + +aggregateInitObservation :: InitObservation -> ExplorerState -> ExplorerState +aggregateInitObservation InitObservation{headId, seedTxIn, contestationPeriod, parties, participants} explorerState = + case findHeadState headId explorerState of + -- REVIEW: this should never happen; how should we deal with this scenario? + Just _headState -> replaceHeadState newHeadState explorerState + Nothing -> newHeadState : explorerState + where + newHeadState = + HeadState + { headId + , seedTxIn + , status = Initializing + , contestationPeriod + , members = + fmap + ( \(party, onChainId) -> + HeadMember + { party + , onChainId + , commits = [] + } + ) + (parties `zip` participants) + } + +aggregateAbortObservation :: AbortObservation -> ExplorerState -> ExplorerState +aggregateAbortObservation AbortObservation{headId} explorerState = + case findHeadState headId explorerState of + Just headState -> + let newHeadState = headState{status = Aborted} + in replaceHeadState newHeadState explorerState + -- REVIEW: this should never happen; how should we deal with this scenario? + Nothing -> explorerState + +aggregateCommitObservation :: CommitObservation -> ExplorerState -> ExplorerState +aggregateCommitObservation CommitObservation{headId, commitOutput, party} explorerState = + case findHeadState headId explorerState of + Just headState -> + let newHeadState = updateMember headState + in replaceHeadState newHeadState explorerState + -- REVIEW: this should never happen; how should we deal with this scenario? + Nothing -> explorerState + where + updateMember headState@HeadState{members} = + case find (\HeadMember{party = partyMember} -> partyMember == party) members of + -- REVIEW: this should never happen; how should we deal with this scenario? + Nothing -> headState + Just headMember@HeadMember{commits = currentCommits} -> + let (txIn, txOut) = commitOutput + newPartyCommit = PartyCommit{txIn, txOut} + newMember = headMember{commits = newPartyCommit : currentCommits} + newMembers = replaceMember members newMember + in headState{members = newMembers} + + replaceMember members newMember@HeadMember{party = newHeadMember} = + case members of + -- REVIEW: this should never happen; how should we deal with this scenario? + [] -> [newMember] + (headMember@HeadMember{party = currentHeadMember} : tailMembers) -> + if newHeadMember == currentHeadMember + then newMember : tailMembers + else headMember : replaceMember tailMembers newMember + +aggregateCollectComObservation :: CollectComObservation -> ExplorerState -> ExplorerState +aggregateCollectComObservation CollectComObservation{headId} explorerState = + case findHeadState headId explorerState of + Just headState -> + let newHeadState = headState{status = Open} + in replaceHeadState newHeadState explorerState + -- REVIEW: this should never happen; how should we deal with this scenario? + Nothing -> explorerState + +aggregateCloseObservation :: CloseObservation -> ExplorerState -> ExplorerState +aggregateCloseObservation CloseObservation{headId} explorerState = + case findHeadState headId explorerState of + Just headState -> + let newHeadState = headState{status = Closed} + in replaceHeadState newHeadState explorerState + -- REVIEW: this should never happen; how should we deal with this scenario? + Nothing -> explorerState + +aggregateContestObservation :: ContestObservation -> ExplorerState -> ExplorerState +aggregateContestObservation ContestObservation{headId} explorerState = + case findHeadState headId explorerState of + Just headState -> + -- REVIEW: should we do smth here? + let newHeadState = headState + in replaceHeadState newHeadState explorerState + -- REVIEW: this should never happen; how should we deal with this scenario? + Nothing -> explorerState + +aggregateFanoutObservation :: FanoutObservation -> ExplorerState -> ExplorerState +aggregateFanoutObservation FanoutObservation{headId} explorerState = + case findHeadState headId explorerState of + Just headState -> + let newHeadState = headState{status = Finalized} + in replaceHeadState newHeadState explorerState + -- REVIEW: this should never happen; how should we deal with this scenario? + Nothing -> explorerState + +replaceHeadState :: HeadState -> ExplorerState -> ExplorerState +replaceHeadState newHeadState@HeadState{headId = newHeadStateId} explorerState = + case explorerState of + [] -> [newHeadState] + (currentHeadState@HeadState{headId = currentHeadStateId} : tailStates) -> + if newHeadStateId == currentHeadStateId + then newHeadState : tailStates + else currentHeadState : replaceHeadState newHeadState tailStates + +aggregateHeadObservations :: [HeadObservation] -> ExplorerState -> ExplorerState +aggregateHeadObservations observations currentState = + foldl' aggregateObservation currentState observations + where + aggregateObservation explorerState = + \case + NoHeadTx -> explorerState + Init obs -> aggregateInitObservation obs explorerState + Abort obs -> aggregateAbortObservation obs explorerState + Commit obs -> aggregateCommitObservation obs explorerState + CollectCom obs -> aggregateCollectComObservation obs explorerState + Close obs -> aggregateCloseObservation obs explorerState + Contest obs -> aggregateContestObservation obs explorerState + Fanout obs -> aggregateFanoutObservation obs explorerState + +findHeadState :: HeadId -> ExplorerState -> Maybe HeadState +findHeadState idToFind = find (\HeadState{headId} -> headId == idToFind) From 2eacbb0e7b424b72f365cdd3e071075eb5c3ad04 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Thu, 18 Jan 2024 19:20:53 +0100 Subject: [PATCH 25/58] Fix assertion for the HeadId equality --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index ad3686c1bab..749feb43daa 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -23,7 +23,6 @@ import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod) import Hydra.Cluster.Util (chainConfigFor, keysFor) import Hydra.Explorer.ExplorerState (HeadState (..), HeadStatus (..)) -import Hydra.HeadId (HeadId (..)) import Hydra.Logging (showLogsOnFailure) import HydraNode (HydraNodeLog, input, output, requestCommitTx, send, waitFor, waitMatch, withHydraNode) import Network.HTTP.Client qualified as HTTPClient @@ -134,8 +133,8 @@ spec = do HTTPClient.responseStatus response `shouldBe` status200 allHeads <- unsafeDecodeJson . toStrict $ HTTPClient.responseBody response length allHeads `shouldBe` 1 - let [HeadState{headId = (UnsafeHeadId idBS), status}] = allHeads - aliceHeadId `shouldBe` decodeUtf8 idBS + let [HeadState{headId = idBS, status}] = allHeads + encode aliceHeadId `shouldBe` encode idBS status `shouldBe` Initializing headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () From c915090f55454ee86c8dfe22a78104ca1e20a8b0 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 19 Jan 2024 14:31:12 +0400 Subject: [PATCH 26/58] Add api server spec to validate openapi schema against server responses Also added json content-type header to the GET /heads endpoint. --- hydra-explorer/hydra-explorer.cabal | 15 +++++- hydra-explorer/src/Hydra/Explorer.hs | 5 +- .../test/Hydra/Explorer/API/HTTPServerSpec.hs | 47 +++++++++++++++++++ 3 files changed, 64 insertions(+), 3 deletions(-) create mode 100644 hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index 4e7f40a42d4..2eb6a30a6ff 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: hydra-explorer version: 0.15.0 synopsis: Hydra Explorer @@ -76,12 +76,23 @@ test-suite tests main-is: Main.hs type: exitcode-stdio-1.0 build-depends: + , aeson + , filepath , hspec + , hspec-wai + , http-types , hydra-explorer , hydra-node , hydra-prelude , hydra-test-utils + , insert-ordered-containers + , openapi3 , QuickCheck + , wai-extra + , yaml + + other-modules: + Hydra.Explorer.API.HTTPServerSpec + Spec - other-modules: Spec build-tool-depends: hspec-discover:hspec-discover diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index c10495c0577..12d98e72669 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -90,7 +90,7 @@ handleGetHeads :: Application handleGetHeads getHeads _req send = do heads <- getHeads - send . responseLBS status200 corsHeaders $ Aeson.encode heads + send . responseLBS status200 (contentTypeHeader : corsHeaders) $ Aeson.encode heads handleError :: Response handleError = @@ -109,3 +109,6 @@ corsHeaders = , ("Access-Control-Allow-Methods", "*") , ("Access-Control-Allow-Headers", "*") ] + +contentTypeHeader :: (HeaderName, ByteString) +contentTypeHeader = ("Content-Type", "application/json") diff --git a/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs b/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs new file mode 100644 index 00000000000..8488ab2a117 --- /dev/null +++ b/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hydra.Explorer.API.HTTPServerSpec where + +import Hydra.Prelude hiding (get) +import Test.Hydra.Prelude + +import Data.Aeson qualified as Aeson +import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap +import Data.OpenApi (sketchSchema, validateJSON) +import Data.Yaml qualified as Yaml +import Hydra.Explorer (httpApp) +import Hydra.Explorer.ExplorerState (HeadState) +import Hydra.Logging (nullTracer) +import Network.HTTP.Types (statusCode) +import Network.Wai.Test (SResponse (..)) +import System.FilePath (()) +import Test.Hspec.Wai (get, with) + +spec :: Spec +spec = apiServerSpec + +apiServerSpec :: Spec +apiServerSpec = do + with (return webServer) $ + describe "API should respond correctly" $ + describe "GET /heads" $ + it "matches schema" $ do + let openApiSchema = "json-schemas" "hydra-explorer-api.yaml" + jsonSchema <- liftIO $ Yaml.decodeFileThrow @_ @Aeson.Value openApiSchema + let schemaSpec = sketchSchema jsonSchema + SResponse{simpleStatus, simpleHeaders, simpleBody} <- get "/heads" + liftIO $ statusCode simpleStatus `shouldBe` 200 + liftIO $ + simpleHeaders + `shouldMatchList` [ ("Access-Control-Allow-Origin", "*") + , ("Access-Control-Allow-Methods", "*") + , ("Access-Control-Allow-Headers", "*") + , ("Content-Type", "application/json") + ] + let (Just value) = Aeson.decode simpleBody :: Maybe Aeson.Value + let validations = validateJSON InsOrdHashMap.empty schemaSpec value + liftIO $ validations `shouldBe` [] + where + webServer = httpApp nullTracer dummyGetHeads + dummyGetHeads :: IO [HeadState] + dummyGetHeads = pure [] From 3b711373ad8a42e9035ec20458b3e4b536ec68f5 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Mon, 22 Jan 2024 13:16:11 +0400 Subject: [PATCH 27/58] Fix match openapi schema spec Do not use cardanonical refs due to openapi schema validation does not support to resolve external refs using $ref. --- hydra-explorer/hydra-explorer.cabal | 3 +- .../json-schemas/hydra-explorer-api.yaml | 119 ++++++++++++++++-- .../src/Hydra/Explorer/ExplorerState.hs | 12 ++ .../test/Hydra/Explorer/API/HTTPServerSpec.hs | 67 +++++++--- 4 files changed, 171 insertions(+), 30 deletions(-) diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index 2eb6a30a6ff..86cc33bbedf 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -77,6 +77,7 @@ test-suite tests type: exitcode-stdio-1.0 build-depends: , aeson + , base , filepath , hspec , hspec-wai @@ -85,7 +86,7 @@ test-suite tests , hydra-node , hydra-prelude , hydra-test-utils - , insert-ordered-containers + , lens , openapi3 , QuickCheck , wai-extra diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index 6759c9f4c28..7498b3c80b3 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -38,27 +38,127 @@ components: type: string description: | A on-chain identifier for a Head participant, hex-encoded as 28 bytes string. - # "$ref": "cardano.json#/definitions/Digest" - # "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Digest" - Commit: + TxIn: + type: string + description: | + A reference to a Cardano transaction output, commonly used as transaction + input and thus named TxIn. Constructed from the transaction's id and + the ouput index, separated by a '#'. + pattern: "^[0-9a-f]{64}#[0-9]+$" + example: "03170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c111314#4" + Address: + type: string + description: | + A bech-32 encoded Cardano address, see + https://github.com/bitcoin/bips/blob/master/bip-0173.mediawiki#Bech32s and + https://github.com/cardano-foundation/CIPs/blob/master/CIP-0005/CIP-0005.md + example: "addr1w9htvds89a78ex2uls5y969ttry9s3k9etww0staxzndwlgmzuul5" + Value: + type: object + description: | + A Cardano value. This is an object containing a number of lovelaces, and + optional assets, mapping some monetary policy identifier to a + mapping of coin (arbitrary strings) to some integer value. + Assets represent native tokens available on the Cardano blockchain, including Non-Fungible Tokens. + additionalProperties: true + properties: + lovelace: + type: integer + minimum: 0 + description: | + A (positive) amount of lovelace + Script: + type: object + additionalProperties: false + required: + - scriptLanguage + - script + properties: + scriptLanguage: + type: string + script: + type: object + additionalProperties: false + required: + - cborHex + - description + - type + properties: + cborHex: + type: string + description: + type: string + type: + type: string + enum: + - SimpleScript + - PlutusScriptV1 + - PlutusScriptV2 + example: + { + "script": { + "cborHex": "8303018282051927168200581c0d94e174732ef9aae73f395ab44507bfa983d65023c11a951f0c32e4", + "description": "", + "type": "SimpleScript" + }, + "scriptLanguage": "SimpleScriptLanguage" + } + TxOut: + type: object + description: | + A single transaction output + required: + - address + - value + additionalProperties: false + properties: + address: + $ref: "#/components/schemas/Address" + value: + $ref: "#/components/schemas/Value" + referenceScript: + $ref: "#/components/schemas/Script" + datumhash: + type: string + inlineDatum: + type: object + additionalProperties: true + inlineDatumhash: + type: string + datum: + type: string + PartyCommit: type: object properties: txIn: - $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/TransactionOutputReference" + $ref: "#/components/schemas/TxIn" txOut: - $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/TransactionOutput" + $ref: "#/components/schemas/TxOut" + Party: + type: object + description: | + The verification key for some Party in the Head protocol, uniquely identifying it. + additionalProperties: false + required: + - vkey + properties: + vkey: + type: string + example: + { + "vkey": "d0b8f28427aa7b640c636075905cbd6574a431aeaca5b3dbafd47cfe66c35043" + } HeadMember: type: object properties: party: - $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/VerificationKey" + $ref: "#/components/schemas/Party" onChainId: $ref: '#/components/schemas/OnChainId' - # "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Digest" commits: type: array items: - $ref: '#/components/schemas/Commit' + $ref: '#/components/schemas/PartyCommit' HeadStatus: type: string enum: @@ -76,7 +176,6 @@ components: type: string description: | A unique identifier for a Head, represented by a hex-encoded 16 bytes string. - # contentEncoding: base16 example: "820082582089ff4f3ff4a6052ec9d073" HeadState: @@ -85,7 +184,7 @@ components: headId: $ref: '#/components/schemas/HeadId' seedTxIn: - $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/TransactionOutputReference" + $ref: '#/components/schemas/TxIn' status: $ref: '#/components/schemas/HeadStatus' contestationPeriod: diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index 2bf7f09f267..c651e0edbee 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -28,6 +28,9 @@ data PartyCommit = PartyCommit deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +instance Arbitrary PartyCommit where + arbitrary = genericArbitrary + data HeadMember = HeadMember { party :: Party , onChainId :: OnChainId @@ -36,6 +39,9 @@ data HeadMember = HeadMember deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +instance Arbitrary HeadMember where + arbitrary = genericArbitrary + data HeadStatus = Initializing | Aborted @@ -45,6 +51,9 @@ data HeadStatus deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +instance Arbitrary HeadStatus where + arbitrary = genericArbitrary + data HeadState = HeadState { headId :: HeadId , seedTxIn :: TxIn @@ -55,6 +64,9 @@ data HeadState = HeadState deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +instance Arbitrary HeadState where + arbitrary = genericArbitrary + type ExplorerState = [HeadState] aggregateInitObservation :: InitObservation -> ExplorerState -> ExplorerState diff --git a/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs b/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs index 8488ab2a117..967ee8a052b 100644 --- a/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs +++ b/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs @@ -5,9 +5,20 @@ module Hydra.Explorer.API.HTTPServerSpec where import Hydra.Prelude hiding (get) import Test.Hydra.Prelude +import Control.Lens (at, (^.), (^?!)) import Data.Aeson qualified as Aeson -import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap -import Data.OpenApi (sketchSchema, validateJSON) +import Data.OpenApi ( + OpenApi (..), + components, + content, + get, + paths, + responses, + schema, + schemas, + validateJSON, + _Inline, + ) import Data.Yaml qualified as Yaml import Hydra.Explorer (httpApp) import Hydra.Explorer.ExplorerState (HeadState) @@ -15,33 +26,51 @@ import Hydra.Logging (nullTracer) import Network.HTTP.Types (statusCode) import Network.Wai.Test (SResponse (..)) import System.FilePath (()) -import Test.Hspec.Wai (get, with) +import Test.Hspec.Wai qualified as Wai +import Test.QuickCheck (generate) spec :: Spec spec = apiServerSpec apiServerSpec :: Spec apiServerSpec = do - with (return webServer) $ + Wai.with (return webServer) $ describe "API should respond correctly" $ describe "GET /heads" $ it "matches schema" $ do let openApiSchema = "json-schemas" "hydra-explorer-api.yaml" - jsonSchema <- liftIO $ Yaml.decodeFileThrow @_ @Aeson.Value openApiSchema - let schemaSpec = sketchSchema jsonSchema - SResponse{simpleStatus, simpleHeaders, simpleBody} <- get "/heads" - liftIO $ statusCode simpleStatus `shouldBe` 200 - liftIO $ - simpleHeaders - `shouldMatchList` [ ("Access-Control-Allow-Origin", "*") - , ("Access-Control-Allow-Methods", "*") - , ("Access-Control-Allow-Headers", "*") - , ("Content-Type", "application/json") - ] - let (Just value) = Aeson.decode simpleBody :: Maybe Aeson.Value - let validations = validateJSON InsOrdHashMap.empty schemaSpec value - liftIO $ validations `shouldBe` [] + openApi <- liftIO $ Yaml.decodeFileThrow @_ @OpenApi openApiSchema + let componentSchemas = openApi ^?! components . schemas + let maybeHeadsSchema = do + path <- openApi ^. paths . at "/heads" + endpoint <- path ^. get + res <- endpoint ^. responses . at 200 + -- XXX: _Inline here assumes that no $ref is used within the + -- openapi Operation + jsonContent <- res ^. _Inline . content . at "application/json" + s <- jsonContent ^. schema + pure $ s ^. _Inline + case maybeHeadsSchema of + Nothing -> liftIO . failure $ "Failed to find schema for GET /heads endpoint" + Just headsSchema -> do + liftIO $ headsSchema `shouldNotBe` mempty + SResponse{simpleStatus, simpleHeaders, simpleBody} <- Wai.get "/heads" + liftIO $ statusCode simpleStatus `shouldBe` 200 + liftIO $ + simpleHeaders + `shouldMatchList` [ ("Access-Control-Allow-Origin", "*") + , ("Access-Control-Allow-Methods", "*") + , ("Access-Control-Allow-Headers", "*") + , ("Content-Type", "application/json") + ] + let maybeValue = Aeson.decode simpleBody :: Maybe Aeson.Value + case maybeValue of + Nothing -> liftIO . failure $ "Failed to decode body into json value" + Just value -> + case validateJSON componentSchemas headsSchema value of + [] -> pure () + errs -> liftIO . failure . toString $ unlines (map toText errs) where webServer = httpApp nullTracer dummyGetHeads dummyGetHeads :: IO [HeadState] - dummyGetHeads = pure [] + dummyGetHeads = generate arbitrary From 9d15d5b15e09c4fca7d7ff0e313dc8351c1f311f Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Mon, 22 Jan 2024 14:32:59 +0400 Subject: [PATCH 28/58] Ehance e2e spec for explorer So it showcases the explorer keeping track of multiple heads. Also make head state aggregation to append the new heads states to the tail of the explorer state. --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 63 +++++++++++++------ .../src/Hydra/Explorer/ExplorerState.hs | 2 +- 2 files changed, 45 insertions(+), 20 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 749feb43daa..31cb83e54f5 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -107,10 +107,10 @@ spec = do withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do let hydraTracer = contramap FromHydraNode tracer hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet - (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice - aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do - withHydraExplorer cardanoNode $ \explorer -> do + withHydraExplorer cardanoNode $ \explorer -> do + (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice + aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) send hydraNode $ input "Init" [] @@ -121,21 +121,46 @@ spec = do headExplorerSees explorer "HeadInitTx" aliceHeadId - manager <- HTTPClient.newTlsManager - let url = "http://127.0.0.1:9090/heads" - request <- - HTTPClient.parseRequest url <&> \request -> - request - { HTTPClient.method = "GET" - , HTTPClient.requestHeaders = [("Accept", "application/json")] - } - response <- HTTPClient.httpLbs request manager - HTTPClient.responseStatus response `shouldBe` status200 - allHeads <- unsafeDecodeJson . toStrict $ HTTPClient.responseBody response - length allHeads `shouldBe` 1 - let [HeadState{headId = idBS, status}] = allHeads - encode aliceHeadId `shouldBe` encode idBS - status `shouldBe` Initializing + pure aliceHeadId + + (bobCardanoVk, _bobCardanoSk) <- keysFor Bob + bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod + bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] $ \hydraNode -> do + seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) + + send hydraNode $ input "Init" [] + + bobHeadId <- waitMatch 5 hydraNode $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsInitializing" + v ^? key "headId" . _String + + headExplorerSees explorer "HeadInitTx" bobHeadId + + send hydraNode $ input "Abort" [] + + headExplorerSees explorer "HeadAbortTx" bobHeadId + + pure bobHeadId + + manager <- HTTPClient.newTlsManager + let url = "http://127.0.0.1:9090/heads" + request <- + HTTPClient.parseRequest url <&> \request -> + request + { HTTPClient.method = "GET" + , HTTPClient.requestHeaders = [("Accept", "application/json")] + } + response <- HTTPClient.httpLbs request manager + HTTPClient.responseStatus response `shouldBe` status200 + allHeads <- unsafeDecodeJson . toStrict $ HTTPClient.responseBody response + length allHeads `shouldBe` 2 + let [ HeadState{headId = aliceIdBS, status = aliceStatus} + , HeadState{headId = bobIdBS, status = bobStatus} + ] = allHeads + encode aliceHeadId `shouldBe` encode aliceIdBS + aliceStatus `shouldBe` Initializing + encode bobHeadId `shouldBe` encode bobIdBS + bobStatus `shouldBe` Aborted headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () headExplorerSees explorer txType headId = diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index c651e0edbee..978a221c7da 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -74,7 +74,7 @@ aggregateInitObservation InitObservation{headId, seedTxIn, contestationPeriod, p case findHeadState headId explorerState of -- REVIEW: this should never happen; how should we deal with this scenario? Just _headState -> replaceHeadState newHeadState explorerState - Nothing -> newHeadState : explorerState + Nothing -> explorerState <> [newHeadState] where newHeadState = HeadState From 03cfee9f26709ed1a7e95cf21318779143f42700 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 12:17:20 +0400 Subject: [PATCH 29/58] Fix chain-observer spec as observeTx is now returning a head observation --- .../test/Hydra/ChainObserverSpec.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs b/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs index a9902743b76..cbc6f00837b 100644 --- a/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs +++ b/hydra-chain-observer/test/Hydra/ChainObserverSpec.hs @@ -6,7 +6,8 @@ import Test.Hydra.Prelude import Hydra.Chain.Direct.Fixture (testNetworkId) import Hydra.Chain.Direct.State (HasKnownUTxO (getKnownUTxO), genChainStateWithTx) import Hydra.Chain.Direct.State qualified as Transition -import Hydra.ChainObserver (ChainObserverLog (..), observeAll, observeTx) +import Hydra.Chain.Direct.Tx (HeadObservation (..)) +import Hydra.ChainObserver (observeAll, observeTx) import Hydra.Ledger.Cardano (genSequenceOfSimplePaymentTransactions) import Test.QuickCheck (counterexample, forAll, forAllBlind, property, (=/=), (===)) import Test.QuickCheck.Property (checkCoverage) @@ -21,13 +22,13 @@ spec = counterexample (show transition) $ let utxo = getKnownUTxO st in case snd $ observeTx testNetworkId utxo tx of - Just (HeadInitTx{}) -> transition === Transition.Init - Just (HeadCommitTx{}) -> transition === Transition.Commit - Just (HeadCollectComTx{}) -> transition === Transition.Collect - Just (HeadAbortTx{}) -> transition === Transition.Abort - Just (HeadCloseTx{}) -> transition === Transition.Close - Just (HeadContestTx{}) -> transition === Transition.Contest - Just (HeadFanoutTx{}) -> transition === Transition.Fanout + Just (Init{}) -> transition === Transition.Init + Just (Commit{}) -> transition === Transition.Commit + Just (CollectCom{}) -> transition === Transition.Collect + Just (Abort{}) -> transition === Transition.Abort + Just (Close{}) -> transition === Transition.Close + Just (Contest{}) -> transition === Transition.Contest + Just (Fanout{}) -> transition === Transition.Fanout _ -> property False prop "Updates UTxO state given transaction part of Head lifecycle" $ From 25d25bcc7b57ad51449debd2adedd514c151cb5a Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 12:22:11 +0400 Subject: [PATCH 30/58] Remove unused packages --- hydra-explorer/hydra-explorer.cabal | 4 ---- 1 file changed, 4 deletions(-) diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index 86cc33bbedf..b47a1cdcdd9 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -45,15 +45,12 @@ library build-depends: , aeson , base - , bytestring - , containers , http-types , hydra-cardano-api , hydra-chain-observer , hydra-node , hydra-prelude , io-classes - , optparse-applicative , wai , warp @@ -77,7 +74,6 @@ test-suite tests type: exitcode-stdio-1.0 build-depends: , aeson - , base , filepath , hspec , hspec-wai From 31bdbc0154d38b20d7e15eaf37170ffa8923b26d Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 12:22:19 +0400 Subject: [PATCH 31/58] Minor fix to readme run cmd --- hydra-explorer/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hydra-explorer/README.md b/hydra-explorer/README.md index d2218a2b14e..13ec1332881 100644 --- a/hydra-explorer/README.md +++ b/hydra-explorer/README.md @@ -8,5 +8,5 @@ To run, pass a `--node-socket`, corresponding network id. For example: ``` shell hydra-explorer \ --node-socket testnets/preprod/node.socket \ - --testnet-magic 1 \ + --testnet-magic 1 ``` From 6b815d43bcfbdc44706987c01aa20775a8fdce11 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 12:22:50 +0400 Subject: [PATCH 32/58] Remove prints before server starts as traces already log this info --- hydra-explorer/src/Hydra/Explorer.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 12d98e72669..b6b233d9b5a 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -58,11 +58,6 @@ main = do & Warp.setPort port & Warp.setHost "0.0.0.0" & Warp.setOnException (\_ e -> traceWith tracer $ APIConnectionError{reason = show e}) - & Warp.setBeforeMainLoop - ( do - putStrLn "Server started..." - putStrLn $ "Listening on: tcp/" <> show port - ) readModelGetHeadIds :: TVar IO ExplorerState -> GetHeads readModelGetHeadIds = readTVarIO From b221cb83eccb0ea2dcd1c35f64832402c86463d6 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 13:48:01 +0400 Subject: [PATCH 33/58] Improve README.md spelling Co-authored-by: Sasha Bogicevic --- hydra-explorer/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hydra-explorer/README.md b/hydra-explorer/README.md index 13ec1332881..d817603478c 100644 --- a/hydra-explorer/README.md +++ b/hydra-explorer/README.md @@ -3,7 +3,7 @@ A small executable which connects to a chain like the `hydra-node`, but puts any observations as traces onto `stdout`. -To run, pass a `--node-socket`, corresponding network id. For example: +To run, pass a `--node-socket` and the corresponding network id. For example: ``` shell hydra-explorer \ From f3e3a0a487d63a8c90e95290aa67fc04cc58e21d Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 13:57:09 +0400 Subject: [PATCH 34/58] Remove not needed endpoints As we are not serving any files yet. Co-authored-by: Sebastian Nagel --- hydra-explorer/src/Hydra/Explorer.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index b6b233d9b5a..820d4a15597 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -73,10 +73,7 @@ httpApp tracer getHeads req send = do } case (requestMethod req, pathInfo req) of ("HEAD", _) -> send $ responseLBS status200 corsHeaders "" - ("GET", []) -> send $ handleFile "index.html" ("GET", ["heads"]) -> handleGetHeads getHeads req send - -- FIXME: do proper file serving, this is dangerous - ("GET", path) -> send $ handleFile $ toString $ mconcat $ List.intersperse "/" ("." : path) (_, _) -> send handleNotFound handleGetHeads :: From 92bfeadfc753706966ce0099fbc808d23441073b Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 14:00:05 +0400 Subject: [PATCH 35/58] Remove unnecessary handle from withChainObserver and withHydraExplorer helpers Co-authored-by: Sebastian Nagel --- hydra-cluster/test/Test/ChainObserverSpec.hs | 1 - hydra-cluster/test/Test/HydraExplorerSpec.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index f066808f50b..ba076d826e2 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -112,7 +112,6 @@ data ChainObserverLog -- | Starts a 'hydra-chain-observer' on some Cardano network. withChainObserver :: RunningNode -> (ChainObserverHandle -> IO ()) -> IO () withChainObserver cardanoNode action = - handle (\(e :: IOException) -> print e >> throwIO e) $ withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph -> action ChainObserverHandle diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 31cb83e54f5..7df6ceebb08 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -204,7 +204,6 @@ data HydraExplorerLog -- | Starts a 'hydra-explorer' on some Cardano network. withHydraExplorer :: RunningNode -> (HydraExplorerHandle -> IO ()) -> IO () withHydraExplorer cardanoNode action = - handle (\(e :: IOException) -> print e >> throwIO e) $ withCreateProcess process{std_out = CreatePipe, std_err = CreatePipe} $ \_in (Just out) err processHandle -> race From 155fad5d48aa9f8cd9d9492edda1196bdf16e44d Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 14:03:43 +0400 Subject: [PATCH 36/58] Update README --- hydra-explorer/README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/hydra-explorer/README.md b/hydra-explorer/README.md index d817603478c..afb451dbb87 100644 --- a/hydra-explorer/README.md +++ b/hydra-explorer/README.md @@ -10,3 +10,7 @@ hydra-explorer \ --node-socket testnets/preprod/node.socket \ --testnet-magic 1 ``` + +Note: this assumes you are running a cardano-node in preprod. + +By definition, hydra-explorer will bind port 9090. \ No newline at end of file From c1f81cc1df36aa27fcb256e5dd8e4225ffa4f781 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 15:22:39 +0400 Subject: [PATCH 37/58] Refactor e2e to use http simple library instead As we do not need use http and to support TLS. Also: - moved the seedFromFaucet_ calls before starting a hydra-node. - fixed the /heads endpoint header to use Accept. - removed some unused packages after this refactor. - remove e2e spec relying on stdout as we are only interested in the http api. --- hydra-cluster/hydra-cluster.cabal | 4 +- hydra-cluster/test/Test/ChainObserverSpec.hs | 10 +- hydra-cluster/test/Test/HydraExplorerSpec.hs | 111 +++++-------------- hydra-explorer/src/Hydra/Explorer.hs | 3 +- 4 files changed, 37 insertions(+), 91 deletions(-) diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index 6c963dcbb36..da1aa50d3e5 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -171,11 +171,9 @@ test-suite tests , filepath , hspec , http-client - , http-client-tls - , http-types + , http-conduit , hydra-cardano-api , hydra-cluster - , hydra-explorer , hydra-node:{hydra-node, testlib} , hydra-prelude , hydra-test-utils diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index ba076d826e2..afc0816520f 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -112,11 +112,11 @@ data ChainObserverLog -- | Starts a 'hydra-chain-observer' on some Cardano network. withChainObserver :: RunningNode -> (ChainObserverHandle -> IO ()) -> IO () withChainObserver cardanoNode action = - withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph -> - action - ChainObserverHandle - { awaitNext = awaitNext out - } + withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph -> + action + ChainObserverHandle + { awaitNext = awaitNext out + } where awaitNext :: Handle -> IO Aeson.Value awaitNext out = do diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 7df6ceebb08..2cfad9d50a7 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-} --- withCreateProcess interface is annoying {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Integration tests for the 'hydra-explorer' executable. These will run @@ -9,69 +8,27 @@ module Test.HydraExplorerSpec where import Hydra.Prelude hiding (get) import Test.Hydra.Prelude -import CardanoClient (RunningNode (..), submitTx) -import CardanoNode (NodeLog, unsafeDecodeJson, withCardanoNodeDevnet) +import CardanoClient (RunningNode (..)) +import CardanoNode (NodeLog, withCardanoNodeDevnet) import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) -import Control.Exception (IOException) -import Control.Lens ((^?)) +import Control.Lens ((^.), (^?)) import Data.Aeson as Aeson -import Data.Aeson.Lens (key, _String) +import Data.Aeson.Lens (key, nth, _Array, _String) import Data.ByteString (hGetLine) import Data.Text qualified as T import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile) import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod) import Hydra.Cluster.Util (chainConfigFor, keysFor) -import Hydra.Explorer.ExplorerState (HeadState (..), HeadStatus (..)) import Hydra.Logging (showLogsOnFailure) -import HydraNode (HydraNodeLog, input, output, requestCommitTx, send, waitFor, waitMatch, withHydraNode) -import Network.HTTP.Client qualified as HTTPClient -import Network.HTTP.Client.TLS qualified as HTTPClient -import Network.HTTP.Types.Status (status200) +import HydraNode (HydraNodeLog, input, send, waitMatch, withHydraNode) +import Network.HTTP.Client (responseBody) +import Network.HTTP.Simple (httpJSON, parseRequestThrow, setRequestHeader) import System.IO.Error (isEOFError, isIllegalOperation) import System.Process (CreateProcess (..), StdStream (..), proc, withCreateProcess) spec :: Spec spec = do - it "can observe hydra transactions live" $ - failAfter 60 $ - showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do - withTempDir "hydra-explorer-live" $ \tmpDir -> do - withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do - let hydraTracer = contramap FromHydraNode tracer - hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet - (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice - aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do - withHydraExplorer cardanoNode $ \explorer -> do - seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) - - send hydraNode $ input "Init" [] - - headId <- waitMatch 5 hydraNode $ \v -> do - guard $ v ^? key "tag" == Just "HeadIsInitializing" - v ^? key "headId" . _String - - headExplorerSees explorer "HeadInitTx" headId - - requestCommitTx hydraNode mempty >>= submitTx cardanoNode - waitFor hydraTracer 5 [hydraNode] $ - output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] - - headExplorerSees explorer "HeadCommitTx" headId - headExplorerSees explorer "HeadCollectComTx" headId - - send hydraNode $ input "Close" [] - - headExplorerSees explorer "HeadCloseTx" headId - - waitFor hydraTracer 50 [hydraNode] $ - output "ReadyToFanout" ["headId" .= headId] - - send hydraNode $ input "Fanout" [] - - headExplorerSees explorer "HeadFanoutTx" headId - it "can observe hydra transactions created by multiple hydra-nodes" $ failAfter 60 $ showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do @@ -87,13 +44,13 @@ spec = do v ^? key "headId" . _String (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice - seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] initHead (bobCardanoVk, _bobCardanoSk) <- keysFor Bob - seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod + seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initHead withHydraExplorer cardanoNode $ \explorer -> do @@ -110,9 +67,8 @@ spec = do withHydraExplorer cardanoNode $ \explorer -> do (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do - seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) - send hydraNode $ input "Init" [] aliceHeadId <- waitMatch 5 hydraNode $ \v -> do @@ -125,9 +81,8 @@ spec = do (bobCardanoVk, _bobCardanoSk) <- keysFor Bob bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod + seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] $ \hydraNode -> do - seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) - send hydraNode $ input "Init" [] bobHeadId <- waitMatch 5 hydraNode $ \v -> do @@ -142,25 +97,19 @@ spec = do pure bobHeadId - manager <- HTTPClient.newTlsManager - let url = "http://127.0.0.1:9090/heads" - request <- - HTTPClient.parseRequest url <&> \request -> - request - { HTTPClient.method = "GET" - , HTTPClient.requestHeaders = [("Accept", "application/json")] - } - response <- HTTPClient.httpLbs request manager - HTTPClient.responseStatus response `shouldBe` status200 - allHeads <- unsafeDecodeJson . toStrict $ HTTPClient.responseBody response - length allHeads `shouldBe` 2 - let [ HeadState{headId = aliceIdBS, status = aliceStatus} - , HeadState{headId = bobIdBS, status = bobStatus} - ] = allHeads - encode aliceHeadId `shouldBe` encode aliceIdBS - aliceStatus `shouldBe` Initializing - encode bobHeadId `shouldBe` encode bobIdBS - bobStatus `shouldBe` Aborted + response <- + parseRequestThrow "http://127.0.0.1:9090/heads" + <&> setRequestHeader "Accept" ["application/json"] + >>= httpJSON + + let allHeads :: Aeson.Value = responseBody response + length (allHeads ^. _Array) `shouldBe` 2 + allHeads ^. nth 0 . key "headId" . _String `shouldBe` aliceHeadId + allHeads ^. nth 0 . key "status" . _String `shouldBe` "Initializing" + allHeads ^. nth 1 . key "headId" . _String `shouldBe` bobHeadId + allHeads ^. nth 1 . key "status" . _String `shouldBe` "Aborted" + + pure () headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () headExplorerSees explorer txType headId = @@ -204,12 +153,12 @@ data HydraExplorerLog -- | Starts a 'hydra-explorer' on some Cardano network. withHydraExplorer :: RunningNode -> (HydraExplorerHandle -> IO ()) -> IO () withHydraExplorer cardanoNode action = - withCreateProcess process{std_out = CreatePipe, std_err = CreatePipe} $ - \_in (Just out) err processHandle -> - race - (checkProcessHasNotDied "hydra-explorer" processHandle err) - (action HydraExplorerHandle{awaitNext = awaitNext out}) - <&> either absurd id + withCreateProcess process{std_out = CreatePipe, std_err = CreatePipe} $ + \_in (Just out) err processHandle -> + race + (checkProcessHasNotDied "hydra-explorer" processHandle err) + (action HydraExplorerHandle{awaitNext = awaitNext out}) + <&> either absurd id where awaitNext :: Handle -> IO Aeson.Value awaitNext out = do diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 820d4a15597..5c153c9ed80 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -8,7 +8,6 @@ import Hydra.Network (PortNumber) import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) import Data.Aeson qualified as Aeson -import Data.List qualified as List import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) import Hydra.Chain.Direct.Tx ( HeadObservation (..), @@ -103,4 +102,4 @@ corsHeaders = ] contentTypeHeader :: (HeaderName, ByteString) -contentTypeHeader = ("Content-Type", "application/json") +contentTypeHeader = ("Accept", "application/json") From 9de27edf2fed8f80769e41a7da77271d18711a38 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 15:26:18 +0400 Subject: [PATCH 38/58] Remove unimplemented endpoint from openapi spec --- .../json-schemas/hydra-explorer-api.yaml | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index 7498b3c80b3..3103eaeffb1 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -15,22 +15,6 @@ paths: type: array items: $ref: '#/components/schemas/HeadState' - /heads/{headId}: - get: - summary: Get head by ID - parameters: - - in: path - name: headId - required: true - schema: - $ref: '#/components/schemas/HeadId' - responses: - '200': - description: Successful response - content: - application/json: - schema: - $ref: '#/components/schemas/HeadState' components: schemas: From 8590af7e5b43b25d47f507f2844ae68855898cf4 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 15:29:05 +0400 Subject: [PATCH 39/58] Rename test module to match where the actual code is implemented --- hydra-explorer/hydra-explorer.cabal | 2 +- .../Hydra/{Explorer/API/HTTPServerSpec.hs => ExplorerSpec.hs} | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) rename hydra-explorer/test/Hydra/{Explorer/API/HTTPServerSpec.hs => ExplorerSpec.hs} (98%) diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index b47a1cdcdd9..e63b92b6a38 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -89,7 +89,7 @@ test-suite tests , yaml other-modules: - Hydra.Explorer.API.HTTPServerSpec + Hydra.ExplorerSpec Spec build-tool-depends: hspec-discover:hspec-discover diff --git a/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs b/hydra-explorer/test/Hydra/ExplorerSpec.hs similarity index 98% rename from hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs rename to hydra-explorer/test/Hydra/ExplorerSpec.hs index 967ee8a052b..15aa2901719 100644 --- a/hydra-explorer/test/Hydra/Explorer/API/HTTPServerSpec.hs +++ b/hydra-explorer/test/Hydra/ExplorerSpec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Hydra.Explorer.API.HTTPServerSpec where +module Hydra.ExplorerSpec where import Hydra.Prelude hiding (get) import Test.Hydra.Prelude From 41b6cf7742735a5ae0c7bd51459e04d380485c11 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 15:34:45 +0400 Subject: [PATCH 40/58] Improve explorer spec to only assert on headers that we care about --- hydra-explorer/test/Hydra/ExplorerSpec.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/hydra-explorer/test/Hydra/ExplorerSpec.hs b/hydra-explorer/test/Hydra/ExplorerSpec.hs index 15aa2901719..64d422ab563 100644 --- a/hydra-explorer/test/Hydra/ExplorerSpec.hs +++ b/hydra-explorer/test/Hydra/ExplorerSpec.hs @@ -56,13 +56,7 @@ apiServerSpec = do liftIO $ headsSchema `shouldNotBe` mempty SResponse{simpleStatus, simpleHeaders, simpleBody} <- Wai.get "/heads" liftIO $ statusCode simpleStatus `shouldBe` 200 - liftIO $ - simpleHeaders - `shouldMatchList` [ ("Access-Control-Allow-Origin", "*") - , ("Access-Control-Allow-Methods", "*") - , ("Access-Control-Allow-Headers", "*") - , ("Content-Type", "application/json") - ] + liftIO $ simpleHeaders `shouldContain` [("Accept", "application/json")] let maybeValue = Aeson.decode simpleBody :: Maybe Aeson.Value case maybeValue of Nothing -> liftIO . failure $ "Failed to decode body into json value" From de9e9439631825c760527fdd96de6f523742ff6f Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 15:38:28 +0400 Subject: [PATCH 41/58] Update explorer api spec to specify required fields --- hydra-explorer/json-schemas/hydra-explorer-api.yaml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index 3103eaeffb1..618ec2a334f 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -134,6 +134,9 @@ components: } HeadMember: type: object + required: + - party + - onChainId properties: party: $ref: "#/components/schemas/Party" @@ -164,6 +167,9 @@ components: "820082582089ff4f3ff4a6052ec9d073" HeadState: type: object + required: + - headId + - status properties: headId: $ref: '#/components/schemas/HeadId' From d9d9853816d2a3676892223b4425ed856986a39c Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 15:43:25 +0400 Subject: [PATCH 42/58] Use eitherDecode to print why the responded bytes where not a proper JSON value --- hydra-explorer/test/Hydra/ExplorerSpec.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/hydra-explorer/test/Hydra/ExplorerSpec.hs b/hydra-explorer/test/Hydra/ExplorerSpec.hs index 64d422ab563..7fb49cfa25e 100644 --- a/hydra-explorer/test/Hydra/ExplorerSpec.hs +++ b/hydra-explorer/test/Hydra/ExplorerSpec.hs @@ -57,10 +57,9 @@ apiServerSpec = do SResponse{simpleStatus, simpleHeaders, simpleBody} <- Wai.get "/heads" liftIO $ statusCode simpleStatus `shouldBe` 200 liftIO $ simpleHeaders `shouldContain` [("Accept", "application/json")] - let maybeValue = Aeson.decode simpleBody :: Maybe Aeson.Value - case maybeValue of - Nothing -> liftIO . failure $ "Failed to decode body into json value" - Just value -> + case Aeson.eitherDecode simpleBody of + Left err -> liftIO . failure $ "Failed to decode body: " <> err + Right value -> case validateJSON componentSchemas headsSchema value of [] -> pure () errs -> liftIO . failure . toString $ unlines (map toText errs) From bdb28b8e6a54dc0306d300b4ada2df45b6d7c2dc Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 16:10:01 +0400 Subject: [PATCH 43/58] Refactor HydraExplorerHandle as an easy access to the API (= a client) And assert REST API behavior rather than std out logs. --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 91 ++++---------------- 1 file changed, 19 insertions(+), 72 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 2cfad9d50a7..9b64dfcd1c7 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Integration tests for the 'hydra-explorer' executable. These will run -- also 'hydra-node' on a devnet and assert correct observation. @@ -10,12 +9,9 @@ import Test.Hydra.Prelude import CardanoClient (RunningNode (..)) import CardanoNode (NodeLog, withCardanoNodeDevnet) -import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) import Control.Lens ((^.), (^?)) import Data.Aeson as Aeson import Data.Aeson.Lens (key, nth, _Array, _String) -import Data.ByteString (hGetLine) -import Data.Text qualified as T import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile) import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_) import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod) @@ -23,8 +19,7 @@ import Hydra.Cluster.Util (chainConfigFor, keysFor) import Hydra.Logging (showLogsOnFailure) import HydraNode (HydraNodeLog, input, send, waitMatch, withHydraNode) import Network.HTTP.Client (responseBody) -import Network.HTTP.Simple (httpJSON, parseRequestThrow, setRequestHeader) -import System.IO.Error (isEOFError, isIllegalOperation) +import Network.HTTP.Simple (httpJSON, parseRequestThrow) import System.Process (CreateProcess (..), StdStream (..), proc, withCreateProcess) spec :: Spec @@ -54,8 +49,12 @@ spec = do bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initHead withHydraExplorer cardanoNode $ \explorer -> do - headExplorerSees explorer "HeadInitTx" aliceHeadId - headExplorerSees explorer "HeadInitTx" bobHeadId + allHeads <- getHeads explorer + length (allHeads ^. _Array) `shouldBe` 2 + allHeads ^. nth 0 . key "headId" . _String `shouldBe` aliceHeadId + allHeads ^. nth 0 . key "status" . _String `shouldBe` "Initializing" + allHeads ^. nth 1 . key "headId" . _String `shouldBe` bobHeadId + allHeads ^. nth 1 . key "status" . _String `shouldBe` "Initializing" it "can query for all hydra heads observed" $ failAfter 60 $ @@ -71,14 +70,10 @@ spec = do aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do send hydraNode $ input "Init" [] - aliceHeadId <- waitMatch 5 hydraNode $ \v -> do + waitMatch 5 hydraNode $ \v -> do guard $ v ^? key "tag" == Just "HeadIsInitializing" v ^? key "headId" . _String - headExplorerSees explorer "HeadInitTx" aliceHeadId - - pure aliceHeadId - (bobCardanoVk, _bobCardanoSk) <- keysFor Bob bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) @@ -89,59 +84,22 @@ spec = do guard $ v ^? key "tag" == Just "HeadIsInitializing" v ^? key "headId" . _String - headExplorerSees explorer "HeadInitTx" bobHeadId - send hydraNode $ input "Abort" [] - headExplorerSees explorer "HeadAbortTx" bobHeadId + waitMatch 5 hydraNode $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsAborted" + guard $ v ^? key "headId" . _String == Just bobHeadId pure bobHeadId - response <- - parseRequestThrow "http://127.0.0.1:9090/heads" - <&> setRequestHeader "Accept" ["application/json"] - >>= httpJSON - - let allHeads :: Aeson.Value = responseBody response + allHeads <- getHeads explorer length (allHeads ^. _Array) `shouldBe` 2 allHeads ^. nth 0 . key "headId" . _String `shouldBe` aliceHeadId allHeads ^. nth 0 . key "status" . _String `shouldBe` "Initializing" allHeads ^. nth 1 . key "headId" . _String `shouldBe` bobHeadId allHeads ^. nth 1 . key "status" . _String `shouldBe` "Aborted" - pure () - -headExplorerSees :: HasCallStack => HydraExplorerHandle -> Value -> Text -> IO () -headExplorerSees explorer txType headId = - awaitMatch explorer 5 $ \v -> do - guard $ v ^? key "message" . key "tag" == Just txType - let actualId = v ^? key "message" . key "headId" . _String - guard $ actualId == Just headId - -awaitMatch :: HasCallStack => HydraExplorerHandle -> DiffTime -> (Aeson.Value -> Maybe a) -> IO a -awaitMatch hydraExplorerHandle delay f = do - seenMsgs <- newTVarIO [] - timeout delay (go seenMsgs) >>= \case - Just x -> pure x - Nothing -> do - msgs <- readTVarIO seenMsgs - failure $ - toString $ - unlines - [ "awaitMatch did not match a message within " <> show delay - , padRight ' ' 20 " seen messages:" - <> unlines (align 20 (decodeUtf8 . Aeson.encode <$> msgs)) - ] - where - go seenMsgs = do - msg <- awaitNext hydraExplorerHandle - atomically (modifyTVar' seenMsgs (msg :)) - maybe (go seenMsgs) pure (f msg) - - align _ [] = [] - align n (h : q) = h : fmap (T.replicate n " " <>) q - -newtype HydraExplorerHandle = HydraExplorerHandle {awaitNext :: IO Value} +newtype HydraExplorerHandle = HydraExplorerHandle {getHeads :: IO Value} data HydraExplorerLog = FromCardanoNode NodeLog @@ -154,27 +112,16 @@ data HydraExplorerLog withHydraExplorer :: RunningNode -> (HydraExplorerHandle -> IO ()) -> IO () withHydraExplorer cardanoNode action = withCreateProcess process{std_out = CreatePipe, std_err = CreatePipe} $ - \_in (Just out) err processHandle -> + \_in _stdOut err processHandle -> race (checkProcessHasNotDied "hydra-explorer" processHandle err) - (action HydraExplorerHandle{awaitNext = awaitNext out}) + ( -- XXX: wait for the http server to be listening on port + threadDelay 1 + *> action HydraExplorerHandle{getHeads} + ) <&> either absurd id where - awaitNext :: Handle -> IO Aeson.Value - awaitNext out = do - x <- try (hGetLine out) - case x of - Left e | isEOFError e || isIllegalOperation e -> do - threadDelay 1 - awaitNext out - Left e -> failure $ "awaitNext failed with exception " <> show e - Right d -> do - case Aeson.eitherDecode (fromStrict d) of - Left _err -> do - putBSLn $ "awaitNext failed to decode msg: " <> d - threadDelay 1 - awaitNext out - Right value -> pure value + getHeads = responseBody <$> (parseRequestThrow "http://127.0.0.1:9090/heads" >>= httpJSON) process = proc From 4f0b0eb71ba4f42c2618bec1ea0d3fa3d1fc00a7 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 16:17:32 +0400 Subject: [PATCH 44/58] Remove unused import from chain observer e2e spec --- hydra-cluster/test/Test/ChainObserverSpec.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index afc0816520f..59f4f68fe6b 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -12,7 +12,6 @@ import Test.Hydra.Prelude import CardanoClient (RunningNode (..), submitTx) import CardanoNode (NodeLog, withCardanoNodeDevnet) import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) -import Control.Exception (IOException) import Control.Lens ((^?)) import Data.Aeson as Aeson import Data.Aeson.Lens (key, _String) From 291c7925bd81521e029fac436d31ebba0a5b7b6a Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 16:26:41 +0400 Subject: [PATCH 45/58] Replace PartyCommit by UTxO type --- .../json-schemas/hydra-explorer-api.yaml | 23 +++++++++++++------ .../src/Hydra/Explorer/ExplorerState.hs | 18 ++++----------- 2 files changed, 20 insertions(+), 21 deletions(-) diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index 618ec2a334f..92e44ccdf97 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -111,13 +111,22 @@ components: type: string datum: type: string - PartyCommit: + UTxO: type: object - properties: - txIn: - $ref: "#/components/schemas/TxIn" - txOut: - $ref: "#/components/schemas/TxOut" + additionalProperties: true + propertyNames: + pattern: "^[0-9a-f]{64}#[0-9]+$" + items: + $ref: "#/components/schemas/TxOut" + example: + { + "09d34606abdcd0b10ebc89307cbfa0b469f9144194137b45b7a04b273961add8#687": { + "address": "addr1w9htvds89a78ex2uls5y969ttry9s3k9etww0staxzndwlgmzuul5", + "value": { + "lovelace": 7620669 + } + } + } Party: type: object description: | @@ -145,7 +154,7 @@ components: commits: type: array items: - $ref: '#/components/schemas/PartyCommit' + $ref: '#/components/schemas/UTxO' HeadStatus: type: string enum: diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index 978a221c7da..d47cc9ed3db 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -5,8 +5,8 @@ import Hydra.Prelude -- XXX: Depending on hydra-node will be problematic to support versions import Hydra.HeadId (HeadId (..)) -import Hydra.Cardano.Api (TxIn, TxOut) -import Hydra.Cardano.Api.Prelude (CtxUTxO) +import Cardano.Api.UTxO qualified as UTxO +import Hydra.Cardano.Api (TxIn, UTxO) import Hydra.Chain.Direct.Tx ( AbortObservation (..), CloseObservation (..), @@ -21,20 +21,10 @@ import Hydra.ContestationPeriod (ContestationPeriod) import Hydra.OnChainId (OnChainId) import Hydra.Party (Party) -data PartyCommit = PartyCommit - { txIn :: TxIn - , txOut :: TxOut CtxUTxO - } - deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -instance Arbitrary PartyCommit where - arbitrary = genericArbitrary - data HeadMember = HeadMember { party :: Party , onChainId :: OnChainId - , commits :: [PartyCommit] + , commits :: [UTxO] } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -118,7 +108,7 @@ aggregateCommitObservation CommitObservation{headId, commitOutput, party} explor Nothing -> headState Just headMember@HeadMember{commits = currentCommits} -> let (txIn, txOut) = commitOutput - newPartyCommit = PartyCommit{txIn, txOut} + newPartyCommit = UTxO.singleton (txIn, txOut) newMember = headMember{commits = newPartyCommit : currentCommits} newMembers = replaceMember members newMember in headState{members = newMembers} From c49c38a36371671d3573c1763c43bf64ac7aaa85 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Tue, 23 Jan 2024 16:28:49 +0400 Subject: [PATCH 46/58] Increase the time dealy to wait for the explorer http server to be listening on port Because it was flaky as it was defined. --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 9b64dfcd1c7..85ee3529678 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -116,7 +116,7 @@ withHydraExplorer cardanoNode action = race (checkProcessHasNotDied "hydra-explorer" processHandle err) ( -- XXX: wait for the http server to be listening on port - threadDelay 1 + threadDelay 3 *> action HydraExplorerHandle{getHeads} ) <&> either absurd id From 24fde0fe8235ddb4f71b8700d2d42d97ac48d062 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Wed, 24 Jan 2024 12:04:04 +0400 Subject: [PATCH 47/58] Draft property spec for aggregate head observations Added arbitrary instances for head observations. --- hydra-explorer/hydra-explorer.cabal | 1 + .../test/Hydra/Explorer/ExplorerStateSpec.hs | 29 ++++++++++++++ hydra-node/src/Hydra/Chain/Direct/Tx.hs | 40 +++++++++++++++---- 3 files changed, 62 insertions(+), 8 deletions(-) create mode 100644 hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index e63b92b6a38..fead64f37a7 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -89,6 +89,7 @@ test-suite tests , yaml other-modules: + Hydra.Explorer.ExplorerStateSpec Hydra.ExplorerSpec Spec diff --git a/hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs b/hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs new file mode 100644 index 00000000000..657eaa163a3 --- /dev/null +++ b/hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs @@ -0,0 +1,29 @@ +module Hydra.Explorer.ExplorerStateSpec where + +import Hydra.Prelude +import Test.Hydra.Prelude + +import Hydra.Chain.Direct.Tx (HeadObservation (..)) +import Hydra.Explorer.ExplorerState (ExplorerState, aggregateHeadObservations, headId) +import Hydra.HeadId (HeadId) +import Test.QuickCheck (forAll, suchThat, (=/=)) + +spec :: Spec +spec = do + describe "aggregate head observation into explorer state" $ do + -- This ensures that the explorer always at least knows about the existence of a head. + -- Even if we only observe a part of the life cycle of some head. + prop "Any head observations (of some head id) must yield an entry of that head id" $ + forAll genObservations $ \observations -> + aggregateHeadObservations observations [] =/= [] + prop "Given any observations, the resulting list of head ids is a prefix of the original" $ + forAll genObservations $ \observations -> + forAll arbitrary $ \initialState -> do + let resultHeads = aggregateHeadObservations observations initialState + getHeadIds initialState `isPrefixOf` getHeadIds resultHeads + where + genObservations :: Gen [HeadObservation] + genObservations = arbitrary `suchThat` (not . null) + + getHeadIds :: ExplorerState -> [HeadId] + getHeadIds = fmap headId diff --git a/hydra-node/src/Hydra/Chain/Direct/Tx.hs b/hydra-node/src/Hydra/Chain/Direct/Tx.hs index 11c75af4ab7..70b16097527 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Tx.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Tx.hs @@ -645,7 +645,10 @@ data HeadObservation | Close CloseObservation | Contest ContestObservation | Fanout FanoutObservation - deriving (Eq, Show) + deriving stock (Eq, Show, Generic) + +instance Arbitrary HeadObservation where + arbitrary = genericArbitrary -- | Observe any Hydra head transaction. observeHeadTx :: NetworkId -> UTxO -> Tx -> HeadObservation @@ -673,7 +676,10 @@ data InitObservation = InitObservation , -- XXX: Improve naming participants :: [OnChainId] } - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) + +instance Arbitrary InitObservation where + arbitrary = genericArbitrary data NotAnInitReason = NoHeadOutput @@ -762,7 +768,10 @@ data CommitObservation = CommitObservation , committed :: UTxO , headId :: HeadId } - deriving (Eq, Show) + deriving stock (Eq, Show, Generic) + +instance Arbitrary CommitObservation where + arbitrary = genericArbitrary -- | Identify a commit tx by: -- @@ -833,7 +842,10 @@ data CollectComObservation = CollectComObservation , headId :: HeadId , utxoHash :: UTxOHash } - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) + +instance Arbitrary CollectComObservation where + arbitrary = genericArbitrary -- | Identify a collectCom tx by lookup up the input spending the Head output -- and decoding its redeemer. @@ -878,7 +890,10 @@ data CloseObservation = CloseObservation , headId :: HeadId , snapshotNumber :: SnapshotNumber } - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) + +instance Arbitrary CloseObservation where + arbitrary = genericArbitrary -- | Identify a close tx by lookup up the input spending the Head output and -- decoding its redeemer. @@ -923,7 +938,10 @@ data ContestObservation = ContestObservation , snapshotNumber :: SnapshotNumber , contesters :: [Plutus.PubKeyHash] } - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) + +instance Arbitrary ContestObservation where + arbitrary = genericArbitrary -- | Identify a close tx by lookup up the input spending the Head output and -- decoding its redeemer. @@ -960,7 +978,10 @@ observeContestTx utxo tx = do Just Head.Closed{snapshotNumber} -> snapshotNumber _ -> error "wrong state in output datum" -newtype FanoutObservation = FanoutObservation {headId :: HeadId} deriving (Eq, Show) +newtype FanoutObservation = FanoutObservation {headId :: HeadId} deriving stock (Eq, Show, Generic) + +instance Arbitrary FanoutObservation where + arbitrary = genericArbitrary -- | Identify a fanout tx by lookup up the input spending the Head output and -- decoding its redeemer. @@ -980,7 +1001,10 @@ observeFanoutTx utxo tx = do where headScript = fromPlutusScript Head.validatorScript -newtype AbortObservation = AbortObservation {headId :: HeadId} deriving (Eq, Show) +newtype AbortObservation = AbortObservation {headId :: HeadId} deriving stock (Eq, Show, Generic) + +instance Arbitrary AbortObservation where + arbitrary = genericArbitrary -- | Identify an abort tx by looking up the input spending the Head output and -- decoding its redeemer. From 8309f53812b125647aa954551a24fa580ff2df86 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Wed, 24 Jan 2024 12:42:26 +0400 Subject: [PATCH 48/58] Update aggregate observation logic to fulfill the expected properties Also: - refactor HeadState.seedTxIn to be Observed. - refactor HeadState.contestationPeriod to be Observed. - refactor HeadMember.onChainId to be Observed. Finally updated the explorer openapi to be compliant with above changes. --- .../json-schemas/hydra-explorer-api.yaml | 1 - .../src/Hydra/Explorer/ExplorerState.hs | 148 +++++++++++++++--- .../test/Hydra/Explorer/ExplorerStateSpec.hs | 3 +- 3 files changed, 124 insertions(+), 28 deletions(-) diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index 92e44ccdf97..d465b6c5434 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -145,7 +145,6 @@ components: type: object required: - party - - onChainId properties: party: $ref: "#/components/schemas/Party" diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index d47cc9ed3db..2312b8ede4f 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -6,24 +6,27 @@ import Hydra.Prelude import Hydra.HeadId (HeadId (..)) import Cardano.Api.UTxO qualified as UTxO +import Data.Aeson (Value (..)) import Hydra.Cardano.Api (TxIn, UTxO) import Hydra.Chain.Direct.Tx ( AbortObservation (..), CloseObservation (..), + ClosedThreadOutput (..), CollectComObservation (..), CommitObservation (..), ContestObservation (..), FanoutObservation (..), HeadObservation (..), InitObservation (..), + OpenThreadOutput (..), ) -import Hydra.ContestationPeriod (ContestationPeriod) +import Hydra.ContestationPeriod (ContestationPeriod, fromChain) import Hydra.OnChainId (OnChainId) -import Hydra.Party (Party) +import Hydra.Party (Party, partyFromChain) data HeadMember = HeadMember { party :: Party - , onChainId :: OnChainId + , onChainId :: Observed OnChainId , commits :: [UTxO] } deriving stock (Eq, Show, Generic) @@ -44,11 +47,25 @@ data HeadStatus instance Arbitrary HeadStatus where arbitrary = genericArbitrary +data Observed a = Unknown | Seen a + deriving stock (Eq, Show, Generic) + +instance ToJSON a => ToJSON (Observed a) where + toJSON Unknown = Null + toJSON (Seen a) = toJSON a + +instance FromJSON a => FromJSON (Observed a) where + parseJSON Null = pure Unknown + parseJSON value = Seen <$> parseJSON value + +instance Arbitrary a => Arbitrary (Observed a) where + arbitrary = genericArbitrary + data HeadState = HeadState { headId :: HeadId - , seedTxIn :: TxIn + , seedTxIn :: Observed TxIn , status :: HeadStatus - , contestationPeriod :: ContestationPeriod + , contestationPeriod :: Observed ContestationPeriod , members :: [HeadMember] } deriving stock (Eq, Show, Generic) @@ -62,16 +79,15 @@ type ExplorerState = [HeadState] aggregateInitObservation :: InitObservation -> ExplorerState -> ExplorerState aggregateInitObservation InitObservation{headId, seedTxIn, contestationPeriod, parties, participants} explorerState = case findHeadState headId explorerState of - -- REVIEW: this should never happen; how should we deal with this scenario? Just _headState -> replaceHeadState newHeadState explorerState Nothing -> explorerState <> [newHeadState] where newHeadState = HeadState { headId - , seedTxIn + , seedTxIn = Seen seedTxIn , status = Initializing - , contestationPeriod + , contestationPeriod = Seen contestationPeriod , members = fmap ( \(party, onChainId) -> @@ -81,7 +97,7 @@ aggregateInitObservation InitObservation{headId, seedTxIn, contestationPeriod, p , commits = [] } ) - (parties `zip` participants) + (parties `zip` fmap Seen participants) } aggregateAbortObservation :: AbortObservation -> ExplorerState -> ExplorerState @@ -90,8 +106,16 @@ aggregateAbortObservation AbortObservation{headId} explorerState = Just headState -> let newHeadState = headState{status = Aborted} in replaceHeadState newHeadState explorerState - -- REVIEW: this should never happen; how should we deal with this scenario? - Nothing -> explorerState + Nothing -> explorerState <> [newUnknownHeadState] + where + newUnknownHeadState = + HeadState + { headId + , seedTxIn = Unknown + , status = Aborted + , contestationPeriod = Unknown + , members = [] + } aggregateCommitObservation :: CommitObservation -> ExplorerState -> ExplorerState aggregateCommitObservation CommitObservation{headId, commitOutput, party} explorerState = @@ -99,13 +123,11 @@ aggregateCommitObservation CommitObservation{headId, commitOutput, party} explor Just headState -> let newHeadState = updateMember headState in replaceHeadState newHeadState explorerState - -- REVIEW: this should never happen; how should we deal with this scenario? - Nothing -> explorerState + Nothing -> explorerState <> [newUnknownHeadState] where updateMember headState@HeadState{members} = case find (\HeadMember{party = partyMember} -> partyMember == party) members of - -- REVIEW: this should never happen; how should we deal with this scenario? - Nothing -> headState + Nothing -> headState{members = newUnknownMember : members} Just headMember@HeadMember{commits = currentCommits} -> let (txIn, txOut) = commitOutput newPartyCommit = UTxO.singleton (txIn, txOut) @@ -115,30 +137,88 @@ aggregateCommitObservation CommitObservation{headId, commitOutput, party} explor replaceMember members newMember@HeadMember{party = newHeadMember} = case members of - -- REVIEW: this should never happen; how should we deal with this scenario? [] -> [newMember] (headMember@HeadMember{party = currentHeadMember} : tailMembers) -> if newHeadMember == currentHeadMember then newMember : tailMembers else headMember : replaceMember tailMembers newMember + newUnknownMember = + HeadMember + { party + , onChainId = Unknown + , commits = + [ let (txIn, txOut) = commitOutput + in UTxO.singleton (txIn, txOut) + ] + } + + newUnknownHeadState = + HeadState + { headId + , seedTxIn = Unknown + , status = Initializing + , contestationPeriod = Unknown + , members = [newUnknownMember] + } + aggregateCollectComObservation :: CollectComObservation -> ExplorerState -> ExplorerState -aggregateCollectComObservation CollectComObservation{headId} explorerState = +aggregateCollectComObservation CollectComObservation{headId, threadOutput = OpenThreadOutput{openContestationPeriod, openParties}} explorerState = case findHeadState headId explorerState of Just headState -> let newHeadState = headState{status = Open} in replaceHeadState newHeadState explorerState - -- REVIEW: this should never happen; how should we deal with this scenario? - Nothing -> explorerState + Nothing -> explorerState <> [newUnknownHeadState] + where + newUnknownHeadState = + HeadState + { headId + , seedTxIn = Unknown + , status = Open + , contestationPeriod = Seen (fromChain openContestationPeriod) + , members = + concatMap + ( fmap + ( \partyMember -> + HeadMember + { party = partyMember + , onChainId = Unknown + , commits = [] + } + ) + . partyFromChain + ) + openParties + } aggregateCloseObservation :: CloseObservation -> ExplorerState -> ExplorerState -aggregateCloseObservation CloseObservation{headId} explorerState = +aggregateCloseObservation CloseObservation{headId, threadOutput = ClosedThreadOutput{closedParties}} explorerState = case findHeadState headId explorerState of Just headState -> let newHeadState = headState{status = Closed} in replaceHeadState newHeadState explorerState - -- REVIEW: this should never happen; how should we deal with this scenario? - Nothing -> explorerState + Nothing -> explorerState <> [newUnknownHeadState] + where + newUnknownHeadState = + HeadState + { headId + , seedTxIn = Unknown + , status = Closed + , contestationPeriod = Unknown + , members = + concatMap + ( fmap + ( \partyMember -> + HeadMember + { party = partyMember + , onChainId = Unknown + , commits = [] + } + ) + . partyFromChain + ) + closedParties + } aggregateContestObservation :: ContestObservation -> ExplorerState -> ExplorerState aggregateContestObservation ContestObservation{headId} explorerState = @@ -147,8 +227,16 @@ aggregateContestObservation ContestObservation{headId} explorerState = -- REVIEW: should we do smth here? let newHeadState = headState in replaceHeadState newHeadState explorerState - -- REVIEW: this should never happen; how should we deal with this scenario? - Nothing -> explorerState + Nothing -> explorerState <> [newUnknownHeadState] + where + newUnknownHeadState = + HeadState + { headId + , seedTxIn = Unknown + , status = Closed + , contestationPeriod = Unknown + , members = [] + } aggregateFanoutObservation :: FanoutObservation -> ExplorerState -> ExplorerState aggregateFanoutObservation FanoutObservation{headId} explorerState = @@ -156,8 +244,16 @@ aggregateFanoutObservation FanoutObservation{headId} explorerState = Just headState -> let newHeadState = headState{status = Finalized} in replaceHeadState newHeadState explorerState - -- REVIEW: this should never happen; how should we deal with this scenario? - Nothing -> explorerState + Nothing -> explorerState <> [newUnknownHeadState] + where + newUnknownHeadState = + HeadState + { headId + , seedTxIn = Unknown + , status = Finalized + , contestationPeriod = Unknown + , members = [] + } replaceHeadState :: HeadState -> ExplorerState -> ExplorerState replaceHeadState newHeadState@HeadState{headId = newHeadStateId} explorerState = diff --git a/hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs b/hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs index 657eaa163a3..c6446a4c8cb 100644 --- a/hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs +++ b/hydra-explorer/test/Hydra/Explorer/ExplorerStateSpec.hs @@ -6,6 +6,7 @@ import Test.Hydra.Prelude import Hydra.Chain.Direct.Tx (HeadObservation (..)) import Hydra.Explorer.ExplorerState (ExplorerState, aggregateHeadObservations, headId) import Hydra.HeadId (HeadId) +import Hydra.OnChainId () import Test.QuickCheck (forAll, suchThat, (=/=)) spec :: Spec @@ -23,7 +24,7 @@ spec = do getHeadIds initialState `isPrefixOf` getHeadIds resultHeads where genObservations :: Gen [HeadObservation] - genObservations = arbitrary `suchThat` (not . null) + genObservations = arbitrary `suchThat` (not . null) `suchThat` notElem NoHeadTx getHeadIds :: ExplorerState -> [HeadId] getHeadIds = fmap headId From 67406485734eed679c55a6759e7844e6bf1347c3 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 25 Jan 2024 10:05:56 +0400 Subject: [PATCH 49/58] Refactor aggregation to work over OnChainTx type instead of HeadObservation --- .../json-schemas/hydra-explorer-api.yaml | 14 +- .../src/Hydra/Explorer/ExplorerState.hs | 183 ++++++++---------- 2 files changed, 95 insertions(+), 102 deletions(-) diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index d465b6c5434..ca988328354 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -151,9 +151,7 @@ components: onChainId: $ref: '#/components/schemas/OnChainId' commits: - type: array - items: - $ref: '#/components/schemas/UTxO' + $ref: '#/components/schemas/UTxO' HeadStatus: type: string enum: @@ -190,4 +188,12 @@ components: members: type: array items: - $ref: '#/components/schemas/HeadMember' \ No newline at end of file + $ref: '#/components/schemas/HeadMember' + contestations: + type: integer + minimum: 0 + description: | + Number of party members who contested. + snapshotNumber: + type: integer + minimum: 0 \ No newline at end of file diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index 2312b8ede4f..2c6274f82fe 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -3,31 +3,25 @@ module Hydra.Explorer.ExplorerState where import Hydra.Prelude -- XXX: Depending on hydra-node will be problematic to support versions -import Hydra.HeadId (HeadId (..)) +import Hydra.HeadId (HeadId (..), HeadSeed) -import Cardano.Api.UTxO qualified as UTxO import Data.Aeson (Value (..)) -import Hydra.Cardano.Api (TxIn, UTxO) +import Hydra.Cardano.Api (Tx, TxIn, UTxO) +import Hydra.Chain (HeadParameters (..), OnChainTx (..)) +import Hydra.Chain.Direct.Handlers (convertObservation) import Hydra.Chain.Direct.Tx ( - AbortObservation (..), - CloseObservation (..), - ClosedThreadOutput (..), - CollectComObservation (..), - CommitObservation (..), - ContestObservation (..), - FanoutObservation (..), HeadObservation (..), - InitObservation (..), - OpenThreadOutput (..), + headSeedToTxIn, ) -import Hydra.ContestationPeriod (ContestationPeriod, fromChain) +import Hydra.ContestationPeriod (ContestationPeriod) import Hydra.OnChainId (OnChainId) -import Hydra.Party (Party, partyFromChain) +import Hydra.Party (Party) +import Hydra.Snapshot (SnapshotNumber (..)) data HeadMember = HeadMember { party :: Party , onChainId :: Observed OnChainId - , commits :: [UTxO] + , commits :: Observed UTxO } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -48,7 +42,7 @@ instance Arbitrary HeadStatus where arbitrary = genericArbitrary data Observed a = Unknown | Seen a - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show, Generic, Functor) instance ToJSON a => ToJSON (Observed a) where toJSON Unknown = Null @@ -66,7 +60,9 @@ data HeadState = HeadState , seedTxIn :: Observed TxIn , status :: HeadStatus , contestationPeriod :: Observed ContestationPeriod - , members :: [HeadMember] + , members :: Observed [HeadMember] + , contestations :: Observed Natural + , snapshotNumber :: Observed Natural } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -76,8 +72,8 @@ instance Arbitrary HeadState where type ExplorerState = [HeadState] -aggregateInitObservation :: InitObservation -> ExplorerState -> ExplorerState -aggregateInitObservation InitObservation{headId, seedTxIn, contestationPeriod, parties, participants} explorerState = +aggregateInitObservation :: HeadId -> HeadSeed -> HeadParameters -> [OnChainId] -> ExplorerState -> ExplorerState +aggregateInitObservation headId headSeed HeadParameters{parties, contestationPeriod} participants explorerState = case findHeadState headId explorerState of Just _headState -> replaceHeadState newHeadState explorerState Nothing -> explorerState <> [newHeadState] @@ -85,23 +81,26 @@ aggregateInitObservation InitObservation{headId, seedTxIn, contestationPeriod, p newHeadState = HeadState { headId - , seedTxIn = Seen seedTxIn + , seedTxIn = maybe Unknown Seen (headSeedToTxIn headSeed) , status = Initializing , contestationPeriod = Seen contestationPeriod , members = - fmap - ( \(party, onChainId) -> - HeadMember - { party - , onChainId - , commits = [] - } - ) - (parties `zip` fmap Seen participants) + Seen $ + fmap + ( \(party, onChainId) -> + HeadMember + { party + , onChainId = Seen onChainId + , commits = Unknown + } + ) + (parties `zip` participants) + , contestations = Seen 0 + , snapshotNumber = Seen 0 } -aggregateAbortObservation :: AbortObservation -> ExplorerState -> ExplorerState -aggregateAbortObservation AbortObservation{headId} explorerState = +aggregateAbortObservation :: HeadId -> ExplorerState -> ExplorerState +aggregateAbortObservation headId explorerState = case findHeadState headId explorerState of Just headState -> let newHeadState = headState{status = Aborted} @@ -114,11 +113,13 @@ aggregateAbortObservation AbortObservation{headId} explorerState = , seedTxIn = Unknown , status = Aborted , contestationPeriod = Unknown - , members = [] + , members = Unknown + , contestations = Seen 0 + , snapshotNumber = Seen 0 } -aggregateCommitObservation :: CommitObservation -> ExplorerState -> ExplorerState -aggregateCommitObservation CommitObservation{headId, commitOutput, party} explorerState = +aggregateCommitObservation :: HeadId -> Party -> UTxO -> ExplorerState -> ExplorerState +aggregateCommitObservation headId party committed explorerState = case findHeadState headId explorerState of Just headState -> let newHeadState = updateMember headState @@ -126,14 +127,18 @@ aggregateCommitObservation CommitObservation{headId, commitOutput, party} explor Nothing -> explorerState <> [newUnknownHeadState] where updateMember headState@HeadState{members} = - case find (\HeadMember{party = partyMember} -> partyMember == party) members of - Nothing -> headState{members = newUnknownMember : members} - Just headMember@HeadMember{commits = currentCommits} -> - let (txIn, txOut) = commitOutput - newPartyCommit = UTxO.singleton (txIn, txOut) - newMember = headMember{commits = newPartyCommit : currentCommits} - newMembers = replaceMember members newMember - in headState{members = newMembers} + let members' = case members of + Unknown -> [] + Seen ms -> ms + in case find (\HeadMember{party = partyMember} -> partyMember == party) members' of + Nothing -> headState{members = Seen $ newUnknownMember : members'} + Just headMember@HeadMember{commits = currentCommits} -> + let currentCommits' = case currentCommits of + Unknown -> mempty + Seen utxo -> utxo + newMember = headMember{commits = Seen $ committed <> currentCommits'} + newMembers = replaceMember members' newMember + in headState{members = Seen newMembers} replaceMember members newMember@HeadMember{party = newHeadMember} = case members of @@ -147,10 +152,7 @@ aggregateCommitObservation CommitObservation{headId, commitOutput, party} explor HeadMember { party , onChainId = Unknown - , commits = - [ let (txIn, txOut) = commitOutput - in UTxO.singleton (txIn, txOut) - ] + , commits = Seen committed } newUnknownHeadState = @@ -159,11 +161,13 @@ aggregateCommitObservation CommitObservation{headId, commitOutput, party} explor , seedTxIn = Unknown , status = Initializing , contestationPeriod = Unknown - , members = [newUnknownMember] + , members = Seen [newUnknownMember] + , contestations = Seen 0 + , snapshotNumber = Seen 0 } -aggregateCollectComObservation :: CollectComObservation -> ExplorerState -> ExplorerState -aggregateCollectComObservation CollectComObservation{headId, threadOutput = OpenThreadOutput{openContestationPeriod, openParties}} explorerState = +aggregateCollectComObservation :: HeadId -> ExplorerState -> ExplorerState +aggregateCollectComObservation headId explorerState = case findHeadState headId explorerState of Just headState -> let newHeadState = headState{status = Open} @@ -175,27 +179,17 @@ aggregateCollectComObservation CollectComObservation{headId, threadOutput = Open { headId , seedTxIn = Unknown , status = Open - , contestationPeriod = Seen (fromChain openContestationPeriod) - , members = - concatMap - ( fmap - ( \partyMember -> - HeadMember - { party = partyMember - , onChainId = Unknown - , commits = [] - } - ) - . partyFromChain - ) - openParties + , contestationPeriod = Unknown + , members = Unknown + , contestations = Seen 0 + , snapshotNumber = Seen 0 } -aggregateCloseObservation :: CloseObservation -> ExplorerState -> ExplorerState -aggregateCloseObservation CloseObservation{headId, threadOutput = ClosedThreadOutput{closedParties}} explorerState = +aggregateCloseObservation :: HeadId -> SnapshotNumber -> UTCTime -> ExplorerState -> ExplorerState +aggregateCloseObservation headId (UnsafeSnapshotNumber sn) contestationDeadline explorerState = case findHeadState headId explorerState of Just headState -> - let newHeadState = headState{status = Closed} + let newHeadState = headState{status = Closed, contestations = Seen 0, snapshotNumber = Seen sn} in replaceHeadState newHeadState explorerState Nothing -> explorerState <> [newUnknownHeadState] where @@ -205,27 +199,16 @@ aggregateCloseObservation CloseObservation{headId, threadOutput = ClosedThreadOu , seedTxIn = Unknown , status = Closed , contestationPeriod = Unknown - , members = - concatMap - ( fmap - ( \partyMember -> - HeadMember - { party = partyMember - , onChainId = Unknown - , commits = [] - } - ) - . partyFromChain - ) - closedParties + , members = Unknown + , contestations = Seen 0 + , snapshotNumber = Seen sn } -aggregateContestObservation :: ContestObservation -> ExplorerState -> ExplorerState -aggregateContestObservation ContestObservation{headId} explorerState = +aggregateContestObservation :: HeadId -> SnapshotNumber -> ExplorerState -> ExplorerState +aggregateContestObservation headId (UnsafeSnapshotNumber sn) explorerState = case findHeadState headId explorerState of - Just headState -> - -- REVIEW: should we do smth here? - let newHeadState = headState + Just headState@HeadState{contestations} -> + let newHeadState = headState{contestations = (+ 1) <$> contestations, snapshotNumber = Seen sn} in replaceHeadState newHeadState explorerState Nothing -> explorerState <> [newUnknownHeadState] where @@ -235,11 +218,13 @@ aggregateContestObservation ContestObservation{headId} explorerState = , seedTxIn = Unknown , status = Closed , contestationPeriod = Unknown - , members = [] + , members = Unknown + , contestations = Seen 1 + , snapshotNumber = Seen sn } -aggregateFanoutObservation :: FanoutObservation -> ExplorerState -> ExplorerState -aggregateFanoutObservation FanoutObservation{headId} explorerState = +aggregateFanoutObservation :: HeadId -> ExplorerState -> ExplorerState +aggregateFanoutObservation headId explorerState = case findHeadState headId explorerState of Just headState -> let newHeadState = headState{status = Finalized} @@ -252,7 +237,9 @@ aggregateFanoutObservation FanoutObservation{headId} explorerState = , seedTxIn = Unknown , status = Finalized , contestationPeriod = Unknown - , members = [] + , members = Unknown + , contestations = Unknown + , snapshotNumber = Unknown } replaceHeadState :: HeadState -> ExplorerState -> ExplorerState @@ -266,18 +253,18 @@ replaceHeadState newHeadState@HeadState{headId = newHeadStateId} explorerState = aggregateHeadObservations :: [HeadObservation] -> ExplorerState -> ExplorerState aggregateHeadObservations observations currentState = - foldl' aggregateObservation currentState observations + foldl' aggregateOnChainTx currentState (mapMaybe convertObservation observations) where - aggregateObservation explorerState = + aggregateOnChainTx :: ExplorerState -> OnChainTx Tx -> ExplorerState + aggregateOnChainTx explorerState = \case - NoHeadTx -> explorerState - Init obs -> aggregateInitObservation obs explorerState - Abort obs -> aggregateAbortObservation obs explorerState - Commit obs -> aggregateCommitObservation obs explorerState - CollectCom obs -> aggregateCollectComObservation obs explorerState - Close obs -> aggregateCloseObservation obs explorerState - Contest obs -> aggregateContestObservation obs explorerState - Fanout obs -> aggregateFanoutObservation obs explorerState + OnInitTx{headId, headSeed, headParameters, participants} -> aggregateInitObservation headId headSeed headParameters participants explorerState + OnAbortTx{headId} -> aggregateAbortObservation headId explorerState + OnCommitTx{headId, party, committed} -> aggregateCommitObservation headId party committed explorerState + OnCollectComTx{headId} -> aggregateCollectComObservation headId explorerState + OnCloseTx{headId, snapshotNumber, contestationDeadline} -> aggregateCloseObservation headId snapshotNumber contestationDeadline explorerState + OnContestTx{headId, snapshotNumber} -> aggregateContestObservation headId snapshotNumber explorerState + OnFanoutTx{headId} -> aggregateFanoutObservation headId explorerState findHeadState :: HeadId -> ExplorerState -> Maybe HeadState findHeadState idToFind = find (\HeadState{headId} -> headId == idToFind) From a9e48098cf4bc85c90826fe89f396d01a4df1062 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 25 Jan 2024 11:23:27 +0400 Subject: [PATCH 50/58] Add tracking of contestation deadline as part of explorer's head states --- .../json-schemas/hydra-explorer-api.yaml | 13 +++++++++-- .../src/Hydra/Explorer/ExplorerState.hs | 22 ++++++++++++++++--- 2 files changed, 30 insertions(+), 5 deletions(-) diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index ca988328354..9ad9eb77020 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -165,6 +165,14 @@ components: description: | A contestation duration in seconds. example: 60 + SnapshotNumber: + type: integer + minimum: 0 + UTCTime: + type: string + format: "date-time" + description: | + A data and time as measured by a clock without a time zone. It is stored as a string in ISO 8601 format. HeadId: type: string description: | @@ -195,5 +203,6 @@ components: description: | Number of party members who contested. snapshotNumber: - type: integer - minimum: 0 \ No newline at end of file + $ref: '#/components/schemas/SnapshotNumber' + contestationDeadline: + $ref: '#/components/schemas/UTCTime' \ No newline at end of file diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index 2c6274f82fe..0cbadaadff2 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -13,7 +13,7 @@ import Hydra.Chain.Direct.Tx ( HeadObservation (..), headSeedToTxIn, ) -import Hydra.ContestationPeriod (ContestationPeriod) +import Hydra.ContestationPeriod (ContestationPeriod, toNominalDiffTime) import Hydra.OnChainId (OnChainId) import Hydra.Party (Party) import Hydra.Snapshot (SnapshotNumber (..)) @@ -63,6 +63,7 @@ data HeadState = HeadState , members :: Observed [HeadMember] , contestations :: Observed Natural , snapshotNumber :: Observed Natural + , contestationDeadline :: Observed UTCTime } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -97,6 +98,7 @@ aggregateInitObservation headId headSeed HeadParameters{parties, contestationPer (parties `zip` participants) , contestations = Seen 0 , snapshotNumber = Seen 0 + , contestationDeadline = Unknown } aggregateAbortObservation :: HeadId -> ExplorerState -> ExplorerState @@ -116,6 +118,7 @@ aggregateAbortObservation headId explorerState = , members = Unknown , contestations = Seen 0 , snapshotNumber = Seen 0 + , contestationDeadline = Unknown } aggregateCommitObservation :: HeadId -> Party -> UTxO -> ExplorerState -> ExplorerState @@ -164,6 +167,7 @@ aggregateCommitObservation headId party committed explorerState = , members = Seen [newUnknownMember] , contestations = Seen 0 , snapshotNumber = Seen 0 + , contestationDeadline = Unknown } aggregateCollectComObservation :: HeadId -> ExplorerState -> ExplorerState @@ -183,6 +187,7 @@ aggregateCollectComObservation headId explorerState = , members = Unknown , contestations = Seen 0 , snapshotNumber = Seen 0 + , contestationDeadline = Unknown } aggregateCloseObservation :: HeadId -> SnapshotNumber -> UTCTime -> ExplorerState -> ExplorerState @@ -202,13 +207,22 @@ aggregateCloseObservation headId (UnsafeSnapshotNumber sn) contestationDeadline , members = Unknown , contestations = Seen 0 , snapshotNumber = Seen sn + , contestationDeadline = Seen contestationDeadline } aggregateContestObservation :: HeadId -> SnapshotNumber -> ExplorerState -> ExplorerState aggregateContestObservation headId (UnsafeSnapshotNumber sn) explorerState = case findHeadState headId explorerState of - Just headState@HeadState{contestations} -> - let newHeadState = headState{contestations = (+ 1) <$> contestations, snapshotNumber = Seen sn} + Just headState@HeadState{contestations, contestationPeriod, contestationDeadline} -> + let newHeadState = + headState + { contestations = (+ 1) <$> contestations + , snapshotNumber = Seen sn + , contestationDeadline = + case (contestationPeriod, contestationDeadline) of + (Seen cp, Seen cd) -> Seen $ addUTCTime (toNominalDiffTime cp) cd + _ -> Unknown + } in replaceHeadState newHeadState explorerState Nothing -> explorerState <> [newUnknownHeadState] where @@ -221,6 +235,7 @@ aggregateContestObservation headId (UnsafeSnapshotNumber sn) explorerState = , members = Unknown , contestations = Seen 1 , snapshotNumber = Seen sn + , contestationDeadline = Unknown } aggregateFanoutObservation :: HeadId -> ExplorerState -> ExplorerState @@ -240,6 +255,7 @@ aggregateFanoutObservation headId explorerState = , members = Unknown , contestations = Unknown , snapshotNumber = Unknown + , contestationDeadline = Unknown } replaceHeadState :: HeadState -> ExplorerState -> ExplorerState From dca46e5f65722c606baecaebb269db7a780ba681 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 25 Jan 2024 11:30:35 +0400 Subject: [PATCH 51/58] Add head state haddock --- hydra-explorer/src/Hydra/Explorer/ExplorerState.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index 0cbadaadff2..f61da5de8f5 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -55,6 +55,13 @@ instance FromJSON a => FromJSON (Observed a) where instance Arbitrary a => Arbitrary (Observed a) where arbitrary = genericArbitrary +-- | Represents the external appearance of a head state. +-- +-- The decision to observe certain attributes or not is designed to address situations +-- where the explorer observes a head transaction on the chain without its +-- previously expected observation, preventing the loss of information during the transition. +-- Additionally, this simplifies the API for clients, eliminating the need to match against +-- different states. data HeadState = HeadState { headId :: HeadId , seedTxIn :: Observed TxIn From 44e3d769ad6fd4c70d63293ff65a35d4832e954c Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 25 Jan 2024 11:37:16 +0400 Subject: [PATCH 52/58] Remove unsupported attribute propertyNames by swagger --- hydra-explorer/json-schemas/hydra-explorer-api.yaml | 2 -- 1 file changed, 2 deletions(-) diff --git a/hydra-explorer/json-schemas/hydra-explorer-api.yaml b/hydra-explorer/json-schemas/hydra-explorer-api.yaml index 9ad9eb77020..4dd1063b220 100644 --- a/hydra-explorer/json-schemas/hydra-explorer-api.yaml +++ b/hydra-explorer/json-schemas/hydra-explorer-api.yaml @@ -114,8 +114,6 @@ components: UTxO: type: object additionalProperties: true - propertyNames: - pattern: "^[0-9a-f]{64}#[0-9]+$" items: $ref: "#/components/schemas/TxOut" example: From 9ce5965b0fa9b204383ccace6542f736e0dcd938 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Thu, 25 Jan 2024 13:11:08 +0400 Subject: [PATCH 53/58] Minor fix after rebasing --- hydra-cluster/hydra-cluster.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index da1aa50d3e5..ad613ebbc39 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -158,7 +158,6 @@ test-suite tests Test.Hydra.Cluster.FaucetSpec Test.Hydra.Cluster.MithrilSpec Test.HydraExplorerSpec - Test.LogFilterSpec Test.OfflineChainSpec build-depends: From ea0aa8e477d5c90150607bfaf4af936636777a53 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Thu, 25 Jan 2024 15:22:19 +0100 Subject: [PATCH 54/58] Use 5 ADA for internal wallets --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index 85ee3529678..ffbaa35b2ee 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -40,12 +40,12 @@ spec = do (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode aliceCardanoVk 5_000_000 (contramap FromFaucet tracer) aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] initHead (bobCardanoVk, _bobCardanoSk) <- keysFor Bob bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode bobCardanoVk 5_000_000 (contramap FromFaucet tracer) bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initHead withHydraExplorer cardanoNode $ \explorer -> do @@ -66,7 +66,7 @@ spec = do withHydraExplorer cardanoNode $ \explorer -> do (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode aliceCardanoVk 5_000_000 (contramap FromFaucet tracer) aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do send hydraNode $ input "Init" [] @@ -76,7 +76,7 @@ spec = do (bobCardanoVk, _bobCardanoSk) <- keysFor Bob bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode bobCardanoVk 100_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode bobCardanoVk 5_000_000 (contramap FromFaucet tracer) bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] $ \hydraNode -> do send hydraNode $ input "Init" [] From 35a947985de677e7dc84cc65745f4152c64cbe4f Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Thu, 25 Jan 2024 16:23:59 +0100 Subject: [PATCH 55/58] Remove misplaced comment --- hydra-explorer/src/Hydra/Explorer/ExplorerState.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs index f61da5de8f5..9cb150db5c8 100644 --- a/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs +++ b/hydra-explorer/src/Hydra/Explorer/ExplorerState.hs @@ -2,7 +2,6 @@ module Hydra.Explorer.ExplorerState where import Hydra.Prelude --- XXX: Depending on hydra-node will be problematic to support versions import Hydra.HeadId (HeadId (..), HeadSeed) import Data.Aeson (Value (..)) From 0f3ba3b9690390dd2ea69d9472faa5f6a62dc877 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 26 Jan 2024 12:24:14 +0400 Subject: [PATCH 56/58] Refactor http server to use servant --- hydra-explorer/hydra-explorer.cabal | 5 +- hydra-explorer/src/Hydra/Explorer.hs | 146 +++++++++++++++------------ 2 files changed, 84 insertions(+), 67 deletions(-) diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index fead64f37a7..5ec6888cf4f 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -16,6 +16,7 @@ source-repository head common project-config default-language: GHC2021 default-extensions: + NoImplicitPrelude DataKinds DefaultSignatures DeriveAnyClass @@ -26,7 +27,6 @@ common project-config GADTs LambdaCase MultiWayIf - NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternSynonyms @@ -45,12 +45,13 @@ library build-depends: , aeson , base - , http-types , hydra-cardano-api , hydra-chain-observer , hydra-node , hydra-prelude , io-classes + , servant + , servant-server , wai , warp diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index 5c153c9ed80..b36dd703177 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -3,37 +3,87 @@ module Hydra.Explorer where import Hydra.ChainObserver qualified import Hydra.Prelude -import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) -import Hydra.Network (PortNumber) - import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO) -import Data.Aeson qualified as Aeson import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..)) -import Hydra.Chain.Direct.Tx ( - HeadObservation (..), - ) +import Hydra.Chain.Direct.Tx (HeadObservation) import Hydra.Explorer.ExplorerState (ExplorerState, HeadState, aggregateHeadObservations) -import Network.HTTP.Types (status200) -import Network.HTTP.Types.Header (HeaderName) -import Network.HTTP.Types.Status (status404, status500) -import Network.Wai ( - Application, - Response, - pathInfo, - rawPathInfo, - requestMethod, - responseFile, - responseLBS, - ) +import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) +import Hydra.Network (PortNumber) +import Network.Wai (Middleware, Request (..), Response) import Network.Wai.Handler.Warp qualified as Warp +import Servant (Server, throwError) +import Servant.API (Get, Header, JSON, addHeader, (:>)) +import Servant.API.ResponseHeaders (Headers) +import Servant.Server (Application, Handler, err404, err500, serve) import System.Environment (withArgs) +type API = + "heads" + :> Get + '[JSON] + ( Headers + '[ Header "Accept" String + , Header "Access-Control-Allow-Origin" String + , Header "Access-Control-Allow-Methods" String + , Header "Access-Control-Allow-Headers" String + ] + [HeadState] + ) + +type GetHeads = IO [HeadState] + +api :: Proxy API +api = Proxy + +server :: + GetHeads -> + Server API +server = handleGetHeads + +handleGetHeads :: + GetHeads -> + Handler + ( Headers + '[ Header "Accept" String + , Header "Access-Control-Allow-Origin" String + , Header "Access-Control-Allow-Methods" String + , Header "Access-Control-Allow-Headers" String + ] + [HeadState] + ) +handleGetHeads getHeads = do + result <- liftIO $ try getHeads + case result of + Right heads -> do + return $ addHeader "application/json" $ addCorsHeaders heads + Left (_ :: SomeException) -> throwError err500 + +handleUnknownResource :: Request -> Handler Response +handleUnknownResource _req = throwError err404 + +logMiddleware :: Tracer IO APIServerLog -> Middleware +logMiddleware tracer app' req sendResponse = do + liftIO $ + traceWith tracer $ + APIHTTPRequestReceived + { method = Method $ requestMethod req + , path = PathInfo $ rawPathInfo req + } + app' req sendResponse + +httpApp :: Tracer IO APIServerLog -> GetHeads -> Application +httpApp tracer getHeads = + logMiddleware tracer $ serve api $ server getHeads + observerHandler :: TVar IO ExplorerState -> [HeadObservation] -> IO () observerHandler explorerState observations = do atomically $ modifyTVar' explorerState $ aggregateHeadObservations observations +readModelGetHeadIds :: TVar IO ExplorerState -> GetHeads +readModelGetHeadIds = readTVarIO + main :: IO () main = do withTracer (Verbose "hydra-explorer") $ \tracer -> do @@ -42,7 +92,9 @@ main = do args <- getArgs race -- FIXME: this is going to be problematic on mainnet. - (withArgs (args <> ["--start-chain-from", "0"]) $ Hydra.ChainObserver.main (observerHandler explorerState)) + ( withArgs (args <> ["--start-chain-from", "0"]) $ + Hydra.ChainObserver.main (observerHandler explorerState) + ) ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber)) *> Warp.runSettings (settings tracer) (httpApp tracer getHeads) ) @@ -58,48 +110,12 @@ main = do & Warp.setHost "0.0.0.0" & Warp.setOnException (\_ e -> traceWith tracer $ APIConnectionError{reason = show e}) - readModelGetHeadIds :: TVar IO ExplorerState -> GetHeads - readModelGetHeadIds = readTVarIO - -type GetHeads = IO [HeadState] - -httpApp :: Tracer IO APIServerLog -> GetHeads -> Application -httpApp tracer getHeads req send = do - traceWith tracer $ - APIHTTPRequestReceived - { method = Method $ requestMethod req - , path = PathInfo $ rawPathInfo req - } - case (requestMethod req, pathInfo req) of - ("HEAD", _) -> send $ responseLBS status200 corsHeaders "" - ("GET", ["heads"]) -> handleGetHeads getHeads req send - (_, _) -> send handleNotFound - -handleGetHeads :: - -- | Read model of all known head ids - GetHeads -> - Application -handleGetHeads getHeads _req send = do - heads <- getHeads - send . responseLBS status200 (contentTypeHeader : corsHeaders) $ Aeson.encode heads - -handleError :: Response -handleError = - responseLBS status500 corsHeaders "INVALID REQUEST" - -handleNotFound :: Response -handleNotFound = - responseLBS status404 corsHeaders "NOT FOUND" - -handleFile :: FilePath -> Response -handleFile filepath = responseFile status200 corsHeaders filepath Nothing - -corsHeaders :: [(HeaderName, ByteString)] -corsHeaders = - [ ("Access-Control-Allow-Origin", "*") - , ("Access-Control-Allow-Methods", "*") - , ("Access-Control-Allow-Headers", "*") - ] - -contentTypeHeader :: (HeaderName, ByteString) -contentTypeHeader = ("Accept", "application/json") +addCorsHeaders :: + a -> + Headers + [ Header "Access-Control-Allow-Origin" String + , Header "Access-Control-Allow-Methods" String + , Header "Access-Control-Allow-Headers" String + ] + a +addCorsHeaders = addHeader "*" . addHeader "*" . addHeader "*" From 3e7b2d2266eb7bac36f1cfd9e2011094d3c98c1d Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 26 Jan 2024 12:27:23 +0400 Subject: [PATCH 57/58] Fix explorer e2e specs by increasing the amount of fuel provided to each party member --- hydra-cluster/test/Test/HydraExplorerSpec.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs index ffbaa35b2ee..ae86b2c158c 100644 --- a/hydra-cluster/test/Test/HydraExplorerSpec.hs +++ b/hydra-cluster/test/Test/HydraExplorerSpec.hs @@ -40,12 +40,12 @@ spec = do (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode aliceCardanoVk 5_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode aliceCardanoVk 25_000_000 (contramap FromFaucet tracer) aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] initHead (bobCardanoVk, _bobCardanoSk) <- keysFor Bob bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode bobCardanoVk 5_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode bobCardanoVk 25_000_000 (contramap FromFaucet tracer) bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initHead withHydraExplorer cardanoNode $ \explorer -> do @@ -66,7 +66,7 @@ spec = do withHydraExplorer cardanoNode $ \explorer -> do (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode aliceCardanoVk 5_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode aliceCardanoVk 25_000_000 (contramap FromFaucet tracer) aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do send hydraNode $ input "Init" [] @@ -76,7 +76,7 @@ spec = do (bobCardanoVk, _bobCardanoSk) <- keysFor Bob bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod - seedFromFaucet_ cardanoNode bobCardanoVk 5_000_000 (contramap FromFaucet tracer) + seedFromFaucet_ cardanoNode bobCardanoVk 25_000_000 (contramap FromFaucet tracer) bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] $ \hydraNode -> do send hydraNode $ input "Init" [] From 594558b9af42b02bee997e2dfbeb836b2bd9b973 Mon Sep 17 00:00:00 2001 From: Franco Testagrossa Date: Fri, 26 Jan 2024 12:35:21 +0400 Subject: [PATCH 58/58] Minor formatting changes --- hydra-explorer/hydra-explorer.cabal | 2 +- hydra-explorer/src/Hydra/Explorer.hs | 11 +++-------- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal index 5ec6888cf4f..b9dc2b89afc 100644 --- a/hydra-explorer/hydra-explorer.cabal +++ b/hydra-explorer/hydra-explorer.cabal @@ -16,7 +16,6 @@ source-repository head common project-config default-language: GHC2021 default-extensions: - NoImplicitPrelude DataKinds DefaultSignatures DeriveAnyClass @@ -27,6 +26,7 @@ common project-config GADTs LambdaCase MultiWayIf + NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternSynonyms diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs index b36dd703177..7c0e2b19fd4 100644 --- a/hydra-explorer/src/Hydra/Explorer.hs +++ b/hydra-explorer/src/Hydra/Explorer.hs @@ -9,12 +9,12 @@ import Hydra.Chain.Direct.Tx (HeadObservation) import Hydra.Explorer.ExplorerState (ExplorerState, HeadState, aggregateHeadObservations) import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer) import Hydra.Network (PortNumber) -import Network.Wai (Middleware, Request (..), Response) +import Network.Wai (Middleware, Request (..)) import Network.Wai.Handler.Warp qualified as Warp import Servant (Server, throwError) import Servant.API (Get, Header, JSON, addHeader, (:>)) import Servant.API.ResponseHeaders (Headers) -import Servant.Server (Application, Handler, err404, err500, serve) +import Servant.Server (Application, Handler, err500, serve) import System.Environment (withArgs) type API = @@ -35,9 +35,7 @@ type GetHeads = IO [HeadState] api :: Proxy API api = Proxy -server :: - GetHeads -> - Server API +server :: GetHeads -> Server API server = handleGetHeads handleGetHeads :: @@ -58,9 +56,6 @@ handleGetHeads getHeads = do return $ addHeader "application/json" $ addCorsHeaders heads Left (_ :: SomeException) -> throwError err500 -handleUnknownResource :: Request -> Handler Response -handleUnknownResource _req = throwError err404 - logMiddleware :: Tracer IO APIServerLog -> Middleware logMiddleware tracer app' req sendResponse = do liftIO $