GSM: use diffusion layer info for HAA

Concretely, this addresses
#974 in the context of
bootstrap peers, but this code will also work for the "actual" Honest
Availability Assumption of Genesis once implemented on the Network side.

ouroboros-consensus-diffusion/changelog.d/20240429_143457_alexander.esgen_gsm_remote.md

@@ -0,0 +1,5 @@
+### Non-Breaking
+
+- Implemented the Honest Availability Assumption properly (both for
+  Praos/"Genesis Lite" and Genesis) based on newly exposed state by the
+  diffusion layer.

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs

@@ -59,6 +59,7 @@ import qualified Codec.CBOR.Encoding as CBOR
 import           Codec.Serialise (DeserialiseFailure)
 import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
 import           Control.DeepSeq (NFData)
+import           Control.Monad (when)
 import           Control.Monad.Class.MonadTime.SI (MonadTime)
 import           Control.Monad.Class.MonadTimer.SI (MonadTimer)
 import           Control.Tracer (Tracer, contramap, traceWith)
@@ -625,9 +626,10 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   lpGetLedgerPeers = fromMaybe [] <$> getPeersFromCurrentLedger kernel (const True),
                   lpGetLedgerStateJudgement = getLedgerStateJudgement kernel
                 },
-            -- TODO: consensus can use this callback to store information if the
-            -- node is connected to peers other than local roots.
-            Diffusion.daUpdateOutboundConnectionsState = \_ -> return ()
+            Diffusion.daUpdateOutboundConnectionsState =
+              let varOcs = getOutboundConnectionsState kernel in \newOcs -> do
+                oldOcs <- readTVar varOcs
+                when (newOcs /= oldOcs) $ writeTVar varOcs newOcs
           }
 
         localRethrowPolicy :: RethrowPolicy

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs

@@ -94,6 +94,8 @@ import           Ouroboros.Network.NodeToNode (ConnectionId,
 import           Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
 import           Ouroboros.Network.PeerSelection.LedgerPeers.Type
                      (LedgerStateJudgement (..))
+import           Ouroboros.Network.PeerSelection.LocalRootPeers
+                     (OutboundConnectionsState (..))
 import           Ouroboros.Network.PeerSharing (PeerSharingAPI,
                      PeerSharingRegistry, newPeerSharingAPI,
                      newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS,
@@ -149,6 +151,9 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel {
     , setBlockForging        :: [BlockForging m blk] -> m ()
 
     , getPeerSharingAPI      :: PeerSharingAPI addrNTN StdGen m
+
+    , getOutboundConnectionsState
+                             :: StrictTVar m OutboundConnectionsState
     }
 
 -- | Arguments required when initializing a node
@@ -204,6 +209,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
           , varLedgerJudgement
           } = st
 
+    varOutboundConnectionsState <- newTVarIO UntrustedState
+
     do  let GsmNodeKernelArgs {..} = gsmArgs
             gsmTracerArgs          =
               ( castTip . either AF.anchorToTip tipFromHeader . AF.head . fst
@@ -239,9 +246,12 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
                     gsmMarkerFileView
               , GSM.writeGsmState = \x -> atomically $ do
                   writeTVar varLedgerJudgement $ GSM.gsmStateToLedgerJudgement x
-              , -- In the context of bootstrap peers, it is fine to always
-                -- return 'True' as all peers are trusted during syncing.
-                GSM.isHaaSatisfied            = pure True
+              , GSM.isHaaSatisfied            = do
+                  readTVar varOutboundConnectionsState <&> \case
+                    -- See the upstream Haddocks for the exact conditions under
+                    -- which the diffusion layer is in this state.
+                    TrustedStateWithExternalPeers -> True
+                    UntrustedState                -> False
               }
         judgment <- readTVarIO varLedgerJudgement
         void $ forkLinkedThread registry "NodeKernel.GSM" $ case judgment of
@@ -278,6 +288,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
       , getTracers              = tracers
       , setBlockForging         = \a -> atomically . LazySTM.putTMVar blockForgingVar $! a
       , getPeerSharingAPI       = peerSharingAPI
+      , getOutboundConnectionsState
+                                = varOutboundConnectionsState
       }
   where
     blockForgingController :: InternalState m remotePeer localPeer blk