Progress on polymorphic kademlia implementation.

1 files changed, 47 insertions, 44 deletions

diff --git a/Kademlia.hs b/Kademlia.hs
index d29a3240..40874078 100644
--- a/Kademlia.hs
+++ b/Kademlia.hs
@@ -101,6 +101,11 @@ data InsertionReporter ni = InsertionReporter
                           -> IO ()
     }
 
+quietInsertions = InsertionReporter
+    { reportArrival = \_ _ _ -> return ()
+    , reportPingResult = \_ _ _ -> return ()
+    }
+
 contramapIR f ir = InsertionReporter
     { reportArrival = \tm ni nis -> reportArrival ir tm (f ni) (map f nis)
     , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b
@@ -111,72 +116,70 @@ data KademliaSpace nid ni = KademliaSpace
     , kademliaTestBit :: nid -> Word -> Bool
     }
 
-contramapKS f ks = KademliaSpace
+contramapKS f ks = ks
     { kademliaLocation = kademliaLocation ks . f
     }
 
--- insertNode param@TableParameters{..} state info witnessed_ip0 = do
-insertNode ::
-    forall ni nid.
-    (Ord ni) =>
-
-    -- reporter
-    InsertionReporter ni
-
-    -- nil
-    -> R.Info ni nid
- 
-    -- k
-    -> KademliaSpace nid ni
-
-    -- changed
-    -> (RoutingTableChanged ni -> STM (IO ()))
+-- | All the IO operations neccessary to maintain a Kademlia routing table.
+data TableStateIO nid ni = TableStateIO
+    { -- | Write the routing table.  Typically 'writeTVar'.
+      tblWrite :: R.Table ni nid -> STM ()
+
+      -- | Read the routing table.  Typically 'readTVar'.
+    , tblRead :: STM (R.Table ni nid)
+
+      -- | Issue a ping to a remote node and report 'True' if the node
+      -- responded within an acceptable time and 'False' otherwise.
+    , tblPing :: ni -> IO Bool
+
+      -- | Convenience method provided to assist in maintaining state
+      -- consistent with the routing table.  It will be invoked in the same
+      -- transaction that 'tblRead'\/'tblWrite' occured but only when there was
+      -- an interesting change.  The returned IO action will be triggered soon
+      -- afterward.
+      --
+      -- It is not necessary to do anything interesting here.  The following
+      -- trivial implementation is fine:
+      --
+      -- > tblChanged = const $ return $ return ()
+    , tblChanged :: RoutingTableChanged ni -> STM (IO ())
+    }
 
-    -- pingProbe
-    -> (ni -> IO Bool)
+data Kademlia nid ni = Kademlia (InsertionReporter ni)
+                                (KademliaSpace nid ni)
+                                (TableStateIO nid ni)
 
-    -- info
+insertNode ::
+    forall ni nid.  Ord ni =>
+    Kademlia nid ni
     -> ni
-
-    -- var
-    -> TVar (Maybe (R.Info ni nid))
-
-
     -> IO ()
-
-insertNode
-    reporter
-    nil
-    k
-    changed
-    pingProbe
-    info
-    var = do
+insertNode (Kademlia reporter space io) node = do
 
   tm <- utcTimeToPOSIXSeconds <$> getCurrentTime
 
   (ps,reaction) <- atomically $ do
-    tbl <- fromMaybe nil <$> readTVar var
-    let (inserted, ps,t') = R.updateForInbound (kademliaTestBit k) (kademliaLocation k) tm info $ myBuckets tbl
+    tbl <- tblRead io
+    let (inserted, ps,t') = R.updateForInbound (kademliaTestBit space) (kademliaLocation space) tm node tbl
+    tblWrite io t'
     reaction <- if inserted
-                    then changed $ RoutingTableChanged Nothing info tm
+                    then tblChanged io $ RoutingTableChanged Nothing node tm
                     else return $ return ()
-    writeTVar var (Just $ tbl { myBuckets = t' })
     return (ps, reaction)
 
-  reportArrival reporter tm info ps
+  reportArrival reporter tm node ps
   reaction
 
   _ <- fork $ do
     myThreadId >>= flip labelThread "pingResults"
     forM_ ps $ \n -> do
-        b <- pingProbe n
+        b <- tblPing io n
         reportPingResult reporter tm n b
         join $ atomically $ do
-            tbl <- fromMaybe nil <$> readTVar var
-            let (replacements, t') = R.updateForPingResult (kademliaTestBit k) (kademliaLocation k) n b $ myBuckets tbl
-            writeTVar var (Just $ tbl { myBuckets = t' })
-            sequence <$> mapM (\(x,(t,y)) -> changed $ RoutingTableChanged (Just x) y t)
+            tbl <- tblRead io
+            let (replacements, t') = R.updateForPingResult (kademliaTestBit space) (kademliaLocation space) n b tbl
+            tblWrite io t'
+            sequence <$> mapM (\(x,(t,y)) -> tblChanged io $ RoutingTableChanged (Just x) y t)
                               replacements
 
   return ()