From 83f5f2a4964c2c8ee76d7781a9d5dce738541543 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Sat, 4 Feb 2023 15:53:02 +0300
Subject: [PATCH] fixed issue with peer expiring

---
 hbs2-core/lib/HBS2/Net/PeerLocator.hs        | 2 +-
 hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs | 4 +++-
 hbs2-peer/app/PeerInfo.hs                    | 5 +++--
 3 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator.hs b/hbs2-core/lib/HBS2/Net/PeerLocator.hs
index 9ddd8114..e3041a84 100644
--- a/hbs2-core/lib/HBS2/Net/PeerLocator.hs
+++ b/hbs2-core/lib/HBS2/Net/PeerLocator.hs
@@ -14,6 +14,6 @@ data AnyPeerLocator e = forall a . PeerLocator e a => AnyPeerLocator a
 instance HasPeer e => PeerLocator e (AnyPeerLocator e) where
   knownPeers (AnyPeerLocator l) = knownPeers  l
   addPeers (AnyPeerLocator l) = addPeers l
-  delPeers (AnyPeerLocator l) = addPeers l
+  delPeers (AnyPeerLocator l) = delPeers l
 
 
diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs
index 0ffe81d4..04112a4c 100644
--- a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs
+++ b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs
@@ -8,6 +8,8 @@ import Control.Concurrent.STM
 import Data.Set (Set)
 import Data.Set qualified as Set
 
+import Prettyprinter
+
 newtype StaticPeerLocator e =
   StaticPeerLocator (TVar (Set (Peer e)))
 
@@ -17,7 +19,7 @@ newStaticPeerLocator seeds = do
   tv <- liftIO $ newTVarIO (Set.fromList seeds)
   pure $ StaticPeerLocator tv
 
-instance Ord (Peer e) => PeerLocator  e (StaticPeerLocator e)  where
+instance (Ord (Peer e), Pretty (Peer e)) => PeerLocator  e (StaticPeerLocator e)  where
 
   knownPeers (StaticPeerLocator peers) = do
     ps <- liftIO $ readTVarIO  peers
diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs
index ae8a2c65..69ea7edb 100644
--- a/hbs2-peer/app/PeerInfo.hs
+++ b/hbs2-peer/app/PeerInfo.hs
@@ -66,12 +66,13 @@ peerPingLoop :: forall e m . ( HasPeerLocator e m
                              , Request e (PeerHandshake e) m
                              , Sessions e (PeerHandshake e) m
                              , Sessions e (PeerInfo e) m
+                             , Sessions e (KnownPeer e) m
                              , Pretty (Peer e)
                              , MonadIO m
                              )
              => m ()
 peerPingLoop = forever do
-  pause @'Minutes 2 -- FIXME: defaults
+  pause @'Seconds 120 -- FIXME: defaults
   debug "peerPingLoop"
 
   pl <- getPeerLocator @e
@@ -90,5 +91,5 @@ peerPingLoop = forever do
       warn $ "removing peer" <+> pretty p <+> "for not responding to our pings"
       delPeers pl [p]
       expire (PeerInfoKey p)
-
+      expire (KnownPeerKey p)