Merge pull request #1333 from input-output-hk/ehnance-explorer-observ…

…ations-with-time

Enhance explorer observations with chain time

hydra-chain-observer/src/Hydra/ChainObserver.hs

@@ -6,7 +6,9 @@ import Hydra.Prelude
 
 import Hydra.Cardano.Api (
   Block (..),
+  BlockHeader (BlockHeader),
   BlockInMode (..),
+  BlockNo,
   CardanoEra (..),
   ChainPoint,
   ChainSyncClient,
@@ -23,20 +25,16 @@ import Hydra.Cardano.Api (
   chainTipToChainPoint,
   connectToLocalNode,
   convertTx,
+  getChainPoint,
   getTxBody,
   getTxId,
  )
 import Hydra.Cardano.Api.Prelude (TxId)
+import Hydra.Chain (OnChainTx (..))
 import Hydra.Chain.CardanoClient (queryTip)
+import Hydra.Chain.Direct.Handlers (convertObservation)
 import Hydra.Chain.Direct.Tx (
-  AbortObservation (..),
-  CloseObservation (..),
-  CollectComObservation (..),
-  CommitObservation (..),
-  ContestObservation (..),
-  FanoutObservation (..),
   HeadObservation (..),
-  InitObservation (..),
   observeHeadTx,
  )
 import Hydra.ChainObserver.Options (Options (..), hydraChainObserverOptions)
@@ -53,7 +51,22 @@ import Ouroboros.Network.Protocol.ChainSync.Client (
   ClientStNext (..),
  )
 
-type ObserverHandler m = [HeadObservation] -> m ()
+type ObserverHandler m = [ChainObservation] -> m ()
+
+data ChainObservation
+  = Tick
+      { point :: ChainPoint
+      , blockNo :: BlockNo
+      }
+  | HeadObservation
+      { point :: ChainPoint
+      , blockNo :: BlockNo
+      , onChainTx :: OnChainTx Tx
+      }
+  deriving stock (Eq, Show, Generic)
+
+instance Arbitrary ChainObservation where
+  arbitrary = genericArbitrary
 
 defaultObserverHandler :: Applicative m => ObserverHandler m
 defaultObserverHandler = const $ pure ()
@@ -162,32 +175,38 @@ chainSyncClient tracer networkId startingPoint observerHandler =
                 BlockInMode ConwayEra (Block _header conwayTxs) -> mapMaybe convertTx conwayTxs
                 BlockInMode BabbageEra (Block _header babbageTxs) -> babbageTxs
                 _ -> []
+
+              (BlockInMode _ (Block bh@(BlockHeader _ _ blockNo) _)) = blockInMode
+              pointInBlock = getChainPoint bh
           traceWith
             tracer
             RollForward
               { point = chainTipToChainPoint tip
               , receivedTxIds = getTxId . getTxBody <$> txs
               }
           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
+              onChainTxs = mapMaybe convertObservation observations
+          forM_ onChainTxs (traceWith tracer . logOnChainTx)
+          let observationsAt = HeadObservation pointInBlock blockNo <$> onChainTxs
+          if null observationsAt
+            then observerHandler [Tick pointInBlock blockNo]
+            else observerHandler observationsAt
+          observerHandler observationsAt
           pure $ clientStIdle utxo'
       , recvMsgRollBackward = \point _tip -> ChainSyncClient $ do
           traceWith tracer Rollback{point}
           pure $ clientStIdle utxo
       }
 
-  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}
+  logOnChainTx :: OnChainTx Tx -> ChainObserverLog
+  logOnChainTx = \case
+    OnInitTx{headId} -> HeadInitTx{headId}
+    OnCommitTx{headId} -> HeadCommitTx{headId}
+    OnCollectComTx{headId} -> HeadCollectComTx{headId}
+    OnCloseTx{headId} -> HeadCloseTx{headId}
+    OnFanoutTx{headId} -> HeadFanoutTx{headId}
+    OnAbortTx{headId} -> HeadAbortTx{headId}
+    OnContestTx{headId} -> HeadContestTx{headId}
 
 observeTx :: NetworkId -> UTxO -> Tx -> (UTxO, Maybe HeadObservation)
 observeTx networkId utxo tx =

hydra-cluster/test/Test/HydraExplorerSpec.hs

@@ -7,11 +7,11 @@ module Test.HydraExplorerSpec where
 import Hydra.Prelude hiding (get)
 import Test.Hydra.Prelude
 
-import CardanoClient (RunningNode (..))
+import CardanoClient (RunningNode (..), queryTip)
 import CardanoNode (NodeLog, withCardanoNodeDevnet)
 import Control.Lens ((^.), (^?))
 import Data.Aeson as Aeson
-import Data.Aeson.Lens (key, nth, _Array, _String)
+import Data.Aeson.Lens (key, nth, _Array, _Number, _String)
 import Hydra.Cardano.Api (ChainPoint (..))
 import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_)
 import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod)
@@ -101,7 +101,27 @@ spec = do
               allHeads ^. nth 1 . key "headId" . _String `shouldBe` bobHeadId
               allHeads ^. nth 1 . key "status" . _String `shouldBe` "Aborted"
 
-newtype HydraExplorerHandle = HydraExplorerHandle {getHeads :: IO Value}
+  it "can query for latest point in time observed on chain" $
+    failAfter 60 $
+      showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do
+        withTempDir "hydra-explorer-get-tick" $ \tmpDir -> do
+          withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket, networkId} -> do
+            withHydraExplorer cardanoNode Nothing $ \explorer -> do
+              tip <- toJSON <$> queryTip networkId nodeSocket
+              tick <- getTick explorer
+
+              let tipSlot = tip ^? key "slot" . _Number
+                  tickSlot = tick ^? key "point" . key "slot" . _Number
+              tipSlot `shouldBe` tickSlot
+
+              let tipBlockHash = tip ^? key "blockHash" . _String
+                  tickBlockHash = tick ^? key "point" . key "blockHash" . _String
+              tipBlockHash `shouldBe` tickBlockHash
+
+data HydraExplorerHandle = HydraExplorerHandle
+  { getHeads :: IO Value
+  , getTick :: IO Value
+  }
 
 data HydraExplorerLog
   = FromCardanoNode NodeLog
@@ -119,12 +139,14 @@ withHydraExplorer cardanoNode mStartChainFrom action =
         (checkProcessHasNotDied "hydra-explorer" processHandle err)
         ( -- XXX: wait for the http server to be listening on port
           threadDelay 3
-            *> action HydraExplorerHandle{getHeads}
+            *> action HydraExplorerHandle{getHeads, getTick}
         )
         <&> either absurd id
  where
   getHeads = responseBody <$> (parseRequestThrow "http://127.0.0.1:9090/heads" >>= httpJSON)
 
+  getTick = responseBody <$> (parseRequestThrow "http://127.0.0.1:9090/tick" >>= httpJSON)
+
   process =
     proc
       "hydra-explorer"

hydra-explorer/exe/Main.hs

@@ -1,7 +1,11 @@
 module Main where
 
-import Hydra.Explorer qualified
 import Hydra.Prelude
 
+import Hydra.Explorer (run)
+import Hydra.Explorer.Options (hydraExplorerOptions)
+import Options.Applicative (execParser)
+
 main :: IO ()
-main = Hydra.Explorer.main
+main =
+  execParser hydraExplorerOptions >>= run

hydra-explorer/hydra-explorer.cabal

@@ -45,7 +45,6 @@ library
   build-depends:
     , aeson
     , base
-    , directory
     , hydra-cardano-api
     , hydra-chain-observer
     , hydra-node
@@ -55,6 +54,7 @@ library
     , servant
     , servant-server
     , wai
+    , wai-cors
     , warp
 
   exposed-modules:
@@ -70,6 +70,7 @@ executable hydra-explorer
   build-depends:
     , hydra-explorer
     , hydra-prelude
+    , optparse-applicative
 
 test-suite tests
   import:             project-config
@@ -83,6 +84,7 @@ test-suite tests
     , hspec
     , hspec-wai
     , http-types
+    , hydra-chain-observer
     , hydra-explorer
     , hydra-node
     , hydra-prelude

hydra-explorer/json-schemas/hydra-explorer-api.yaml

@@ -3,6 +3,24 @@ info:
   title: Head Explorer API
   version: 1.0.0
 paths:
+  /tick:
+    get:
+      summary: Get the latest point in time obseverd on chain by the explorer
+      responses:
+        '200':
+          description: Successful response
+          content:
+            application/json:
+              schema:
+                type: object
+                required:
+                  - point
+                  - blockNo
+                properties:
+                  point:
+                    $ref: '#/components/schemas/ChainPoint'
+                  blockNo:
+                    type: integer
   /heads:
     get:
       summary: Get a list of head states
@@ -177,11 +195,35 @@ components:
         A unique identifier for a Head, represented by a hex-encoded 16 bytes string.
       example:
         "820082582089ff4f3ff4a6052ec9d073"
+    ChainPoint:
+      oneOf:
+        - title: ChainPointAtGenesis
+          required:
+            - tag
+          properties:
+            tag:
+              type: string
+              enum: ["ChainPointAtGenesis"]
+        - title: ChainPoint
+          required:
+            - tag
+            - slot
+            - blockHash
+          properties:
+            tag:
+              type: string
+              enum: ["ChainPoint"]
+            slot:
+              type: integer
+            blockHash:
+              type: string
     HeadState:
       type: object
       required:
         - headId
         - status
+        - point
+        - blockNo
       properties:
         headId:
           $ref: '#/components/schemas/HeadId'
@@ -203,4 +245,8 @@ components:
         snapshotNumber:
           $ref: '#/components/schemas/SnapshotNumber'
         contestationDeadline:
-          $ref: '#/components/schemas/UTCTime'
+          $ref: '#/components/schemas/UTCTime'
+        point:
+          $ref: '#/components/schemas/ChainPoint'
+        blockNo:
+          type: integer