Actually (partially) parse confirmed snapshot from Hydra

src/Kupo/App/ChainSync/Hydra.hs

@@ -2,7 +2,6 @@
 --  License, v. 2.0. If a copy of the MPL was not distributed with this
 --  file, You can obtain one at http://mozilla.org/MPL/2.0/.
 
-{-# LANGUAGE PatternSynonyms #-}
 module Kupo.App.ChainSync.Hydra
     ( connect
     , runChainSyncClient
@@ -16,17 +15,13 @@ import Control.Exception.Safe
 import Kupo.App.Mailbox
     ( Mailbox
     , putHighFrequencyMessage
-    , putIntermittentMessage
     )
 import Kupo.Control.MonadSTM
     ( MonadSTM (..)
     )
 import Kupo.Data.Cardano
     ( Point
-    , SlotNo
     , Tip
-    , WithOrigin
-    , pointSlot
     )
 import Kupo.Data.ChainSync
     ( IntersectionNotFoundException (..)
@@ -35,22 +30,10 @@ import Kupo.Data.Ogmios
     ( PartialBlock
     )
 
-import qualified Data.ByteString as BS
-import Kupo.Data.Cardano.HeaderHash
-    ( unsafeHeaderHashFromBytes
-    )
-import Kupo.Data.Cardano.Point
-    ( pattern BlockPoint
-    )
-import Kupo.Data.Cardano.Tip
-    ( pattern Tip
-    )
 import Kupo.Data.Hydra
     ( HydraMessage (..)
     , decodeHydraMessage
-    )
-import Kupo.Data.PartialBlock
-    ( PartialBlock (..)
+    , fromSnapshot
     )
 import qualified Network.WebSockets as WS
 import qualified Network.WebSockets.Json as WS
@@ -66,21 +49,12 @@ runChainSyncClient
     -> [Point]
     -> WS.Connection
     -> m IntersectionNotFoundException
-runChainSyncClient mailbox beforeMainLoop pts ws = do
+runChainSyncClient mailbox beforeMainLoop _pts ws = do
     beforeMainLoop
     forever $ do
         WS.receiveJson ws decodeHydraMessage >>= \case
-            SnapshotConfirmed{} -> do
-                let headerHash = unsafeHeaderHashFromBytes $ BS.replicate 32 0
-                let slotNo = 1 -- TODO: decode snapshot number as slot
-                let blockNo = 1
-                let tip = Tip slotNo headerHash blockNo
-                let block =
-                        PartialBlock
-                            { blockPoint = BlockPoint slotNo headerHash
-                            , blockBody  = []
-                            }
-                atomically (putHighFrequencyMessage mailbox (tip, block))
+            SnapshotConfirmed{ snapshot } -> do
+                atomically (putHighFrequencyMessage mailbox (fromSnapshot snapshot))
             SomethingElse -> pure ()
 
 connect

src/Kupo/Data/Hydra.hs

@@ -1,23 +1,74 @@
+{-# LANGUAGE PatternSynonyms #-}
+
 module Kupo.Data.Hydra where
 
 import Kupo.Prelude
 
+import Cardano.Crypto.Hash
+    ( hashToBytes
+    , hashWith
+    )
 import Data.Aeson
     ( (.:)
     )
+import Kupo.Data.Cardano
+    ( BlockNo (..)
+    , SlotNo (..)
+    , Tip
+    , pattern BlockPoint
+    , pattern Tip
+    , unsafeHeaderHashFromBytes
+    )
+import Kupo.Data.PartialBlock
+    ( PartialBlock (..)
+    )
+
 import qualified Data.Aeson.Types as Json
+import qualified Data.ByteString.Builder as BS
+
+-- Types
 
 data HydraMessage
-  = SnapshotConfirmed
-  | SomethingElse
+    = SnapshotConfirmed { snapshot :: Snapshot }
+    | SomethingElse
+
+data Snapshot = Snapshot
+    { number :: Word64
+    }
+
+fromSnapshot :: Snapshot -> (Tip, PartialBlock)
+fromSnapshot Snapshot { number } = do
+    let
+        headerHash = number
+            & hashWith @Blake2b_256 (toStrict . BS.toLazyByteString . BS.word64BE)
+            & hashToBytes
+            & unsafeHeaderHashFromBytes
 
+        slotNo =
+            SlotNo number
+
+        blockNo =
+            BlockNo number
+     in
+        ( Tip slotNo headerHash blockNo
+        , PartialBlock
+            { blockPoint = BlockPoint slotNo headerHash
+            , blockBody  = []
+            }
+        )
 
 -- Decoders
 
 decodeHydraMessage :: Json.Value -> Json.Parser HydraMessage
 decodeHydraMessage =
-  Json.withObject "HydraMessage" $ \o -> do
-    tag <- o .: "tag"
-    case tag of
-      ("SnapshotConfirmed" :: Text) -> pure SnapshotConfirmed
-      _ -> pure SomethingElse
+    Json.withObject "HydraMessage" $ \o -> do
+        tag <- o .: "tag"
+        case tag of
+            ("SnapshotConfirmed" :: Text) -> SnapshotConfirmed <$> decodeSnapshotConfirmed o
+            _ -> pure SomethingElse
+
+decodeSnapshotConfirmed :: Json.Object -> Json.Parser Snapshot
+decodeSnapshotConfirmed o = do
+    snapshot <- o .: "snapshot"
+    number <- snapshot .: "snapshotNumber"
+    pure $ Snapshot { number }