Implement FetchTip for cardano-node

  Unfortunately, we have to use an MVar to pass return value from the client since 'connectTo' swallows whatever the client is trying to return. This is unfortunate, but also pretty safe given that we are guaranteed to either: exit with an exception or put a tip in the MVar before attempting to take it.

Author: KtorZ

kupo.cabal

@@ -142,6 +142,7 @@ import qualified Kupo.App.ChainSync.Node as Node
 import qualified Kupo.App.ChainSync.Ogmios as Ogmios
 import qualified Kupo.App.FetchBlock.Node as Node
 import qualified Kupo.App.FetchBlock.Ogmios as Ogmios
+import qualified Kupo.App.FetchTip.Node as Node
 import qualified Kupo.App.FetchTip.Ogmios as Ogmios
 
 --
@@ -305,8 +306,20 @@ newFetchTipClient = \case
         throwIO UnableToFetchTipFromHydra
     Ogmios{ogmiosHost, ogmiosPort} ->
         Ogmios.newFetchTipClient ogmiosHost ogmiosPort
-    CardanoNode{} ->
-        error "TODO: newFetchTipClient for CardanoNode"
+    CardanoNode{nodeSocket, nodeConfig} -> do
+        NetworkParameters
+            { networkMagic
+            , slotsPerEpoch
+            } <- liftIO (parseNetworkParameters nodeConfig)
+        response <- newEmptyTMVarIO
+        withChainSyncServer
+            noConnectionStatusToggle
+            [ NodeToClientV_9 .. maxBound ]
+            networkMagic
+            slotsPerEpoch
+            nodeSocket
+            (Node.newFetchTipClient response)
+        atomically $ takeTMVar response
 
 -- | Consumer process that is reading messages from the 'Mailbox'. Messages are
 -- enqueued by another process (the producer).

src/Kupo/App.hs

@@ -0,0 +1,39 @@
+--  This Source Code Form is subject to the terms of the Mozilla Public
+--  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/.
+
+module Kupo.App.FetchTip.Node
+    ( newFetchTipClient
+    ) where
+
+import Kupo.Prelude
+
+import Control.Concurrent.Class.MonadSTM
+    ( MonadSTM (..)
+    )
+import Kupo.Data.Cardano
+    ( Point
+    , Tip
+    )
+import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
+    ( ChainSyncClientPipelined (..)
+    , ClientPipelinedStIdle (..)
+    , ClientStNext (..)
+    )
+
+newFetchTipClient
+    :: (MonadSTM m)
+    => TMVar m Tip
+    -> ChainSyncClientPipelined block Point Tip m ()
+newFetchTipClient response =
+    ChainSyncClientPipelined $ pure $
+        SendMsgRequestNext
+            (pure ())
+            ClientStNext
+                { recvMsgRollForward = \_header tip -> do
+                    atomically $ putTMVar response tip
+                    pure (SendMsgDone ())
+                , recvMsgRollBackward = \_point tip -> do
+                    atomically $ putTMVar response tip
+                    pure (SendMsgDone ())
+                }

src/Kupo/App/FetchTip/Node.hs

@@ -548,6 +548,8 @@ spec = skippableContext "End-to-end" $ do
             }
         runSpec env 120 $ do
             waitSlot (>= getPointSlotNo tip)
+            points <- listCheckpoints
+            forM_ points $ \point -> getPointSlotNo point `shouldSatisfy` (>= getPointSlotNo tip)
             Health{configuration} <- getHealth
             configuration `shouldBe` (Just InstallIndexesIfNotExist)