HACK: add a GET / query to introspect head state

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

@@ -20,6 +20,7 @@ import Hydra.Cardano.Api (
 import Hydra.Chain (Chain (..), CommitBlueprintTx (..), IsChainState, PostTxError (..), draftCommitTx)
 import Hydra.Chain.Direct.State ()
 import Hydra.HeadId (HeadId)
+import Hydra.HeadLogic (HeadState)
 import Hydra.Ledger (IsTx (..))
 import Hydra.Logging (Tracer, traceWith)
 import Network.HTTP.Types (status200, status400, status404, status500)
@@ -128,14 +129,17 @@ httpApp ::
   IO (Maybe HeadId) ->
   -- | Get latest confirmed UTxO snapshot.
   IO (Maybe (UTxOType tx)) ->
+  IO (HeadState tx) ->
   Application
-httpApp tracer directChain pparams getInitializingHeadId getConfirmedUTxO request respond = do
+httpApp tracer directChain pparams getInitializingHeadId getConfirmedUTxO getHeadState request respond = do
   traceWith tracer $
     APIHTTPRequestReceived
       { method = Method $ requestMethod request
       , path = PathInfo $ rawPathInfo request
       }
   case (requestMethod request, pathInfo request) of
+    ("GET", ["head-state"]) ->
+      getHeadState >>= respond . okJSON
     ("GET", ["snapshot", "utxo"]) ->
       -- XXX: Should ensure the UTxO is of the right head and the head is still
       -- open. This is something we should fix on the "read model" side of the

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

@@ -25,6 +25,7 @@ import Hydra.API.WSServer (nextSequenceNumber, wsApp)
 import Hydra.Cardano.Api (LedgerEra)
 import Hydra.Chain (Chain (..), IsChainState)
 import Hydra.Chain.Direct.State ()
+import Hydra.HeadLogic (HeadState)
 import Hydra.Logging (Tracer, traceWith)
 import Hydra.Network (IP, PortNumber)
 import Hydra.Party (Party)
@@ -67,8 +68,9 @@ withAPIServer ::
   Tracer IO APIServerLog ->
   Chain tx IO ->
   PParams LedgerEra ->
+  STM IO (HeadState tx) ->
   ServerComponent tx IO ()
-withAPIServer host port party PersistenceIncremental{loadAll, append} tracer chain pparams callback action =
+withAPIServer host port party PersistenceIncremental{loadAll, append} tracer chain pparams getHeadState callback action =
   handle onIOException $ do
     responseChannel <- newBroadcastTChanIO
     timedOutputEvents <- loadAll
@@ -97,7 +99,14 @@ withAPIServer host port party PersistenceIncremental{loadAll, append} tracer cha
             websocketsOr
               defaultConnectionOptions
               (wsApp party tracer history callback headStatusP snapshotUtxoP responseChannel)
-              (httpApp tracer chain pparams (atomically $ getLatest headIdP) (atomically $ getLatest snapshotUtxoP))
+              ( httpApp
+                  tracer
+                  chain
+                  pparams
+                  (atomically $ getLatest headIdP)
+                  (atomically $ getLatest snapshotUtxoP)
+                  (atomically getHeadState)
+              )
       )
       ( do
           waitForServerRunning

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

@@ -25,10 +25,13 @@ import Hydra.Logging (Verbosity (..), traceWith, withTracer)
 import Hydra.Logging.Messages (HydraLog (..))
 import Hydra.Logging.Monitoring (withMonitoring)
 import Hydra.Node (
+  DraftHydraNode (..),
+  NodeState (..),
   chainStateHistory,
   connect,
   hydrate,
   initEnvironment,
+  queryHeadState,
   runHydraNode,
   wireChainInput,
   wireClientInput,
@@ -82,18 +85,19 @@ run opts = do
               -- NOTE: Add any custom sinks here
               -- , customSink
               ]
-        wetHydraNode <- hydrate (contramap Node tracer) env ledger initialChainState eventSource eventSinks
+        hydraNode <- hydrate (contramap Node tracer) env ledger initialChainState eventSource eventSinks
         -- Chain
         withChain <- prepareChainComponent tracer env chainConfig
-        withChain (chainStateHistory wetHydraNode) (wireChainInput wetHydraNode) $ \chain -> do
+        withChain (chainStateHistory hydraNode) (wireChainInput hydraNode) $ \chain -> do
           -- API
           apiPersistence <- createPersistenceIncremental $ persistenceDir <> "/server-output"
-          withAPIServer apiHost apiPort party apiPersistence (contramap APIServer tracer) chain pparams (wireClientInput wetHydraNode) $ \server -> do
+          let DraftHydraNode{nodeState = NodeState{queryHeadState}} = hydraNode
+          withAPIServer apiHost apiPort party apiPersistence (contramap APIServer tracer) chain pparams queryHeadState (wireClientInput hydraNode) $ \server -> do
             -- Network
             let networkConfiguration = NetworkConfiguration{persistenceDir, signingKey, otherParties, host, port, peers, nodeId}
-            withNetwork tracer networkConfiguration (wireNetworkInput wetHydraNode) $ \network -> do
+            withNetwork tracer networkConfiguration (wireNetworkInput hydraNode) $ \network -> do
               -- Main loop
-              connect chain network server wetHydraNode
+              connect chain network server hydraNode
                 >>= runHydraNode
  where
   withCardanoLedger protocolParams globals action =

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

@@ -35,6 +35,9 @@ import Test.QuickCheck (
   withMaxSuccess,
  )
 
+getFails :: IO a
+getFails = error "should not be used"
+
 spec :: Spec
 spec = do
   parallel $ do
@@ -90,7 +93,7 @@ apiServerSpec = do
     let getNothing = pure Nothing
 
     describe "GET /protocol-parameters" $ do
-      with (return $ httpApp @SimpleTx nullTracer dummyChainHandle defaultPParams getNothing getNothing) $ do
+      with (return $ httpApp @SimpleTx nullTracer dummyChainHandle defaultPParams getNothing getNothing getFails) $ do
         it "matches schema" $
           withJsonSpecifications $ \schemaDir -> do
             get "/protocol-parameters"
@@ -109,7 +112,8 @@ apiServerSpec = do
     describe "GET /snapshot/utxo" $ do
       prop "responds correctly" $ \utxo -> do
         let getUTxO = pure utxo
-        withApplication (httpApp @SimpleTx nullTracer dummyChainHandle defaultPParams getNothing getUTxO) $ do
+            getHeadState = error "should not be used"
+        withApplication (httpApp @SimpleTx nullTracer dummyChainHandle defaultPParams getNothing getUTxO getHeadState) $ do
           get "/snapshot/utxo"
             `shouldRespondWith` case utxo of
               Nothing -> 404
@@ -122,7 +126,8 @@ apiServerSpec = do
           . withJsonSpecifications
           $ \schemaDir -> do
             let getUTxO = pure $ Just utxo
-            withApplication (httpApp @Tx nullTracer dummyChainHandle defaultPParams getNothing getUTxO) $ do
+                getHeadState = error "should not be used"
+            withApplication (httpApp @Tx nullTracer dummyChainHandle defaultPParams getNothing getUTxO getHeadState) $ do
               get "/snapshot/utxo"
                 `shouldRespondWith` 200
                   { matchBody =
@@ -140,7 +145,7 @@ apiServerSpec = do
                   pure $ Right tx
               }
       prop "responds on valid requests" $ \(request :: DraftCommitTxRequest Tx) ->
-        withApplication (httpApp nullTracer workingChainHandle defaultPParams getHeadId getNothing) $ do
+        withApplication (httpApp nullTracer workingChainHandle defaultPParams getHeadId getNothing getFails) $ do
           post "/commit" (Aeson.encode request)
             `shouldRespondWith` 200
 
@@ -164,7 +169,7 @@ apiServerSpec = do
               _ -> property
         checkCoverage $
           coverage $
-            withApplication (httpApp @Tx nullTracer (failingChainHandle postTxError) defaultPParams getHeadId getNothing) $ do
+            withApplication (httpApp @Tx nullTracer (failingChainHandle postTxError) defaultPParams getHeadId getNothing getFails) $ do
               post "/commit" (Aeson.encode (request :: DraftCommitTxRequest Tx))
                 `shouldRespondWith` expectedResponse
 

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

@@ -366,7 +366,7 @@ withTestAPIServer ::
   (Server SimpleTx IO -> IO ()) ->
   IO ()
 withTestAPIServer port actor persistence tracer action = do
-  withAPIServer @SimpleTx "127.0.0.1" port actor persistence tracer dummyChainHandle defaultPParams noop action
+  withAPIServer @SimpleTx "127.0.0.1" port actor persistence tracer dummyChainHandle defaultPParams (error "not implemented") noop action
 
 -- | Connect to a websocket server running at given path. Fails if not connected
 -- within 2 seconds.