Handle failed demotions directly.

Instead of depending on connection monitoring to process cold peers
handle it directly.

ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs

@@ -439,6 +439,11 @@ aboveTargetOther actions
     numActivePeers      = Set.size activePeers
     numDemoteInProgress = Set.size inProgressDemoteHot
 
+-- | Reconnect delay for peers which asynchronously transitioned to cold state.
+--
+reconnectDelay :: DiffTime
+reconnectDelay = 10
+--TODO: make this a policy param
 
 jobDemoteActivePeer :: forall peeraddr peerconn m.
                        (Monad m, Ord peeraddr)
@@ -452,22 +457,43 @@ jobDemoteActivePeer PeerSelectionActions{peerStateActions = PeerStateActions {de
   where
     handler :: SomeException -> m (Completion m peeraddr peerconn)
     handler e = return $
-      -- It's quite bad if closing fails, but the best we can do is revert to
-      -- the state where we believed these peers are still warm, since then we
-      -- can have another go at the ones we didn't yet try to close, or perhaps
-      -- it'll be closed for other reasons and our monitoring will notice it.
+      -- It's quite bad if demoting fails. The peer is cold so
+      -- remove if from the set of established and hot peers.
       Completion $ \st@PeerSelectionState {
                       activePeers,
+                      establishedPeers,
+                      inProgressDemoteHot,
+                      knownPeers,
                       targets = PeerSelectionTargets {
                                   targetNumberOfActivePeers
-                                }
+                                },
+                      fuzzRng
                     }
-                    _now -> Decision {
+                    now ->
+        let (rFuzz, fuzzRng')     = randomR (-2, 2 :: Double) fuzzRng
+            peerSet               = Set.singleton peeraddr
+            activePeers'          = Set.delete peeraddr activePeers
+            inProgressDemoteHot'  = Set.delete peeraddr inProgressDemoteHot
+            knownPeers'           = KnownPeers.setConnectTime
+                                     peerSet
+                                     ((realToFrac rFuzz + reconnectDelay)
+                                      `addTime` now)
+                                   . Set.foldr'
+                                     ((snd .) . KnownPeers.incrementFailCount)
+                                     knownPeers
+                                   $ peerSet
+            establishedPeers'     = EstablishedPeers.deletePeers
+                                     peerSet
+                                     establishedPeers in
+        Decision {
         decisionTrace = TraceDemoteHotFailed targetNumberOfActivePeers
                                              (Set.size activePeers) peeraddr e,
         decisionState = st {
-                          inProgressDemoteHot = Set.delete peeraddr
-                                                  (inProgressDemoteHot st)
+                          inProgressDemoteHot = inProgressDemoteHot',
+                          fuzzRng = fuzzRng',
+                          activePeers = activePeers',
+                          knownPeers = knownPeers',
+                          establishedPeers = establishedPeers'
                         },
         decisionJobs  = []
       }

ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs

@@ -397,6 +397,12 @@ aboveTarget actions
   = GuardedSkip Nothing
 
 
+-- | Reconnect delay for peers which asynchronously transitioned to cold state.
+--
+reconnectDelay :: DiffTime
+reconnectDelay = 10
+--TODO: make this a policy param
+
 jobDemoteEstablishedPeer :: forall peeraddr peerconn m.
                             (Monad m, Ord peeraddr)
                          => PeerSelectionActions peeraddr peerconn m
@@ -409,23 +415,41 @@ jobDemoteEstablishedPeer PeerSelectionActions{peerStateActions = PeerStateAction
   where
     handler :: SomeException -> m (Completion m peeraddr peerconn)
     handler e = return $
-      -- It's quite bad if closing fails, but the best we can do is revert to
-      -- the state where we believed this peer is still warm, since then we
-      -- can have another go or perhaps it'll be closed for other reasons and
-      -- our monitoring will notice it.
+      -- It's quite bad if closing fails. The peer is cold so
+      -- remove if from the set of established.
       Completion $ \st@PeerSelectionState {
                        establishedPeers,
+                       inProgressDemoteWarm,
+                       knownPeers,
                        targets = PeerSelectionTargets {
                                    targetNumberOfEstablishedPeers
-                                 }
+                                 },
+                       fuzzRng
                      }
-                     _now -> Decision {
+                     now ->
+        let (rFuzz, fuzzRng')     = randomR (-2, 2 :: Double) fuzzRng
+            peerSet               = Set.singleton peeraddr
+            inProgressDemoteWarm' = Set.delete peeraddr inProgressDemoteWarm
+            knownPeers'           = KnownPeers.setConnectTime
+                                     peerSet
+                                     ((realToFrac rFuzz + reconnectDelay)
+                                      `addTime` now)
+                                   . Set.foldr'
+                                     ((snd .) . KnownPeers.incrementFailCount)
+                                     knownPeers
+                                   $ peerSet
+            establishedPeers'     = EstablishedPeers.deletePeers
+                                     peerSet
+                                     establishedPeers in
+        Decision {
         decisionTrace = TraceDemoteWarmFailed targetNumberOfEstablishedPeers
                                               (EstablishedPeers.size establishedPeers)
                                               peeraddr e,
         decisionState = st {
-                          inProgressDemoteWarm = Set.delete peeraddr
-                                                   (inProgressDemoteWarm st)
+                          inProgressDemoteWarm = inProgressDemoteWarm',
+                          fuzzRng = fuzzRng',
+                          knownPeers = knownPeers',
+                          establishedPeers = establishedPeers'
                         },
         decisionJobs  = []
       }