bittorrent: Expire old peer announcements.

3 files changed, 33 insertions, 6 deletions

diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs
index c8187772..dfc93ed7 100644
--- a/src/Network/BitTorrent/DHT/ContactInfo.hs
+++ b/src/Network/BitTorrent/DHT/ContactInfo.hs
@@ -5,6 +5,7 @@ module Network.BitTorrent.DHT.ContactInfo
        , Network.BitTorrent.DHT.ContactInfo.lookup
        , Network.BitTorrent.DHT.ContactInfo.freshPeers
        , Network.BitTorrent.DHT.ContactInfo.insertPeer
+       , deleteOlderThan
        , knownSwarms
        ) where
 
@@ -234,3 +235,15 @@ insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarm
  where
     a' = SwarmData { peers = PSQ.singleton a 0
                    , name = name }
+
+deleteOlderThan :: POSIXTime -> PeerStore -> PeerStore
+deleteOlderThan cutoff (PeerStore m) = PeerStore $ HM.mapMaybe gc m
+    where
+        gc :: SwarmData -> Maybe SwarmData
+        gc swarms = fmap (\ps -> swarms { peers = ps }) $ gcPSQ (peers swarms)
+
+        gcPSQ :: PSQKey a => PSQ a Timestamp -> Maybe (PSQ a Timestamp)
+        gcPSQ ps = case minView ps of
+            Nothing                            -> Nothing
+            Just (_ :-> tm, ps') | tm < cutoff -> gcPSQ ps'
+            Just _                             -> Just ps
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index f43b070c..63e67ad3 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -47,7 +47,7 @@ import Data.Monoid
 import Data.Ord
 import qualified Data.Serialize               as S
 import Data.Set                               (Set)
-import Data.Time.Clock.POSIX                  (POSIXTime)
+import Data.Time.Clock.POSIX                  (POSIXTime, getPOSIXTime)
 import Data.Torrent
 import Data.Typeable
 import Data.Word
@@ -631,7 +631,7 @@ newClient swarms addr = do
             , clientResponseId    = return
             }
 
-    -- TODO: Provide some means of shutting down these four auxillary threads:
+    -- TODO: Provide some means of shutting down these five auxillary threads:
 
     fork $ fix $ \again -> do
         myThreadId >>= flip labelThread "addr4"
@@ -656,8 +656,24 @@ newClient swarms addr = do
     refresh_thread4 <- forkPollForRefresh $ refresher4 routing
     refresh_thread6 <- forkPollForRefresh $ refresher6 routing
 
+    forkAnnouncedInfohashesGC (contactInfo swarms)
+
     return (client, routing, bootstrap (refresher4 routing), bootstrap (refresher6 routing))
 
+-- Note that you should call .put() every hour for content that you want to
+-- keep alive, since nodes may discard data nodes older than 2 hours. (source:
+-- https://www.npmjs.com/package/bittorrent-dht)
+--
+-- This function will discard records between 3 and 6 hours old.
+forkAnnouncedInfohashesGC :: TVar PeerStore -> IO ThreadId
+forkAnnouncedInfohashesGC vpeers = fork $ do
+    myThreadId >>= flip labelThread "gc:bt-peers"
+    fix $ \loop -> do
+        cutoff <- getPOSIXTime
+        threadDelay 10800000000 -- 3 hours
+        atomically $ modifyTVar' vpeers $ deleteOlderThan cutoff
+        loop
+
 -- | Modifies a purely random 'NodeId' to one that is related to a given
 -- routable address in accordance with BEP 42.
 --
diff --git a/todo.txt b/todo.txt
index d4b2d828..94fe6cd3 100644
--- a/todo.txt
+++ b/todo.txt
@@ -1,3 +1,5 @@
+tox: XEdDSA signature algorithm and key conversion.
+
 maint: send patch to Vincent Hanquez to implement crypto_box_*
 
 tox: layerTransport handshake decryption: use (SecretKey,SockAddr) as the
@@ -41,10 +43,6 @@ tox: cache diffie-helman secrets
 
 tox: Chat support.
 
-bt: Collect PeerStore garbage: "Note that you should call .put() every hour for
-    content that you want to keep alive, since nodes may discard data nodes
-    older than 2 hours." (source: https://www.npmjs.com/package/bittorrent-dht)
-
 bt: Limit peers in get_peers response for UDP packet size limiting (around 1k).
 
 bt: Use LMDB backend for peer store (and nodes too?).