1 files changed, 143 insertions, 121 deletions

diff --git a/src/Network/DHT/Routing.hs b/src/Network/DHT/Routing.hs
index 5c6abe5d..34d8385f 100644
--- a/src/Network/DHT/Routing.hs
+++ b/src/Network/DHT/Routing.hs
@@ -23,6 +23,7 @@
 {-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Network.DHT.Routing
+       {-
        ( -- * Table
          Table
        , Info(..)
@@ -61,7 +62,7 @@ module Network.DHT.Routing
 
          -- * Routing
        , Timestamp
-       ) where
+       ) -} where
 
 import Control.Applicative as A
 import Control.Arrow
@@ -85,11 +86,6 @@ import Data.Bits
 
 import Network.Address
 
-
-{-----------------------------------------------------------------------
---  Routing monad
------------------------------------------------------------------------}
-
 -- | Last time the node was responding to our queries.
 --
 --   Not all nodes that we learn about are equal. Some are \"good\" and
@@ -107,10 +103,11 @@ import Network.Address
 --
 type Timestamp = POSIXTime
 
+
+
 {-----------------------------------------------------------------------
     Bucket
 -----------------------------------------------------------------------}
--- TODO: add replacement cache to the bucket
 --
 -- When a k-bucket is full and a new node is discovered for that
 -- k-bucket, the least recently seen node in the k-bucket is
@@ -120,16 +117,12 @@ type Timestamp = POSIXTime
 -- other words: new nodes are used only when older nodes disappear.
 
 -- | Timestamp - last time this node is pinged.
-type NodeEntry dht ip u = Binding (NodeInfo dht ip u) Timestamp
-
--- TODO instance Pretty where
+type NodeEntry ni = Binding ni Timestamp
 
--- | Number of nodes in a bucket.
-type BucketSize  = Int
 
 -- | Maximum number of 'NodeInfo's stored in a bucket. Most clients
 -- use this value.
-defaultBucketSize :: BucketSize
+defaultBucketSize :: Int
 defaultBucketSize = 8
 
 data QueueMethods m elem fifo = QueueMethods
@@ -151,7 +144,7 @@ fromQ embed project QueueMethods{..} =
                  }
 -}
 
-seqQ :: QueueMethods Identity (NodeInfo dht ip u) (Seq.Seq (NodeInfo dht ip u))
+seqQ :: QueueMethods Identity ni (Seq.Seq ni)
 seqQ = QueueMethods
     { pushBack = \e fifo -> pure (fifo Seq.|> e)
     , popFront = \fifo -> case Seq.viewl fifo of
@@ -160,11 +153,12 @@ seqQ = QueueMethods
     , emptyQueue = pure Seq.empty
     }
 
-type BucketQueue dht ip u = Seq.Seq (NodeInfo dht ip u)
+type BucketQueue ni = Seq.Seq ni
 
-bucketQ :: QueueMethods Identity (NodeInfo dht ip u) (BucketQueue dht ip u)
+bucketQ :: QueueMethods Identity ni (BucketQueue ni)
 bucketQ = seqQ
 
+
 -- | Bucket is also limited in its length — thus it's called k-bucket.
 --   When bucket becomes full, we should split it in two lists by
 --   current span bit. Span bit is defined by depth in the routing
@@ -172,17 +166,21 @@ bucketQ = seqQ
 --   very unlikely that all nodes in bucket fail within an hour of
 --   each other.
 --
-data Bucket dht ip u = Bucket { bktNodes :: !(PSQ (NodeInfo dht ip u) Timestamp)
-                              , bktQ     :: !(BucketQueue dht ip u)
-                              } deriving Generic
+data Bucket ni = Bucket { bktNodes :: !(PSQ ni Timestamp)
+                        , bktQ     :: !(BucketQueue ni)
+                        } deriving Generic
+
+deriving instance Show ni => Show (Bucket ni)
+
 
-deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Bucket dht ip u)
 
+#if 0
 
-getGenericNode :: ( Serialize (NodeId dht)
+{-
+getGenericNode :: ( Serialize (NodeId)
                   , Serialize ip
                   , Serialize u
-                  ) => Get (NodeInfo dht ip u)
+                  ) => Get (NodeInfo)
 getGenericNode = do
     nid <- get
     naddr <- get
@@ -193,19 +191,21 @@ getGenericNode = do
         , nodeAnnotation = u
         }
 
-putGenericNode :: ( Serialize (NodeId dht)
+putGenericNode :: ( Serialize (NodeId)
                   , Serialize ip
                   , Serialize u
-                  ) => NodeInfo dht ip u -> Put
+                  ) => NodeInfo -> Put
 putGenericNode (NodeInfo nid naddr u) = do
     put nid
     put naddr
     put u
 
-instance (Eq ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize ip, Serialize u) => Serialize (Bucket dht ip u) where
+instance (Eq ip, Ord (NodeId), Serialize (NodeId), Serialize ip, Serialize u) => Serialize (Bucket) where
     get = Bucket . psqFromPairList <$> getListOf ( (,) <$> getGenericNode <*> get ) <*> pure (runIdentity $ emptyQueue bucketQ)
     put = putListOf (\(ni,stamp) -> putGenericNode ni >> put stamp) . psqToPairList . bktNodes
+-}
 
+#endif
 
 psqFromPairList :: (Ord p, Ord k) => [(k, p)] -> OrdPSQ k p ()
 psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs
@@ -220,8 +220,8 @@ delta = 15 * 60
 -- | Should maintain a set of stable long running nodes.
 --
 -- Note: pings are triggerd only when a bucket is full.
-insertBucket :: (Eq ip, Alternative f, Ord (NodeId dht))  => Timestamp -> Event dht ip u -> Bucket dht ip u
-           -> f ([CheckPing dht ip u], Bucket dht ip u)
+insertBucket :: (Alternative f, Ord ni) => -- (Eq ip, Alternative f, Ord (NodeId))  =>
+    Timestamp -> Event ni -> Bucket ni -> f ([CheckPing ni], Bucket ni)
 insertBucket curTime (TryInsert info) bucket
   -- just update timestamp if a node is already in bucket
   | already_have
@@ -272,11 +272,9 @@ insertBucket curTime (PingResult bad_node got_response) bucket
                  pure $ PSQ.insert info curTime nodes'
         | otherwise        = id
 
-updateStamps :: ( Eq ip
-                , Ord (NodeId dht)
-                ) => Timestamp -> [NodeInfo dht ip u] -> PSQ (NodeInfo dht ip u) Timestamp -> PSQ (NodeInfo dht ip u) Timestamp
-updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
 
+updateStamps :: Ord ni => Timestamp -> [ni] -> PSQ ni Timestamp -> PSQ ni Timestamp
+updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
 
 type BitIx = Word
 
@@ -296,42 +294,37 @@ partitionQ imp test q0 = do
                     select f = if test e then \(a,b) -> flip (,) b <$> f a
                                          else \(a,b) ->      (,) a <$> f b
 
-split :: forall dht ip u.
-         ( Eq ip
-         , Ord (NodeId dht)
-         , FiniteBits (NodeId dht)
-         ) => BitIx -> Bucket dht ip u -> (Bucket dht ip u, Bucket dht ip u)
-split i b = (Bucket ns qs, Bucket ms rs)
+
+
+split :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
+    forall ni. Ord ni =>
+    (ni -> Word -> Bool)
+    -> BitIx -> Bucket ni -> (Bucket ni, Bucket ni)
+split testNodeIdBit i b = (Bucket ns qs, Bucket ms rs)
   where
     (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b
     (qs,rs) = runIdentity $ partitionQ bucketQ spanBit $ bktQ b
-    {-
-    spanBit :: forall (dht :: * -> *) addr u.
-               FiniteBits (Network.DatagramServer.Types.NodeId dht) =>
-               NodeInfo dht addr u -> Bool
-    -}
-    spanBit :: NodeInfo dht addr u -> Bool
-    spanBit entry = testIdBit (nodeId entry) i
+
+    spanBit :: ni -> Bool
+    spanBit entry = testNodeIdBit entry i
+
 
 {-----------------------------------------------------------------------
 --  Table
 -----------------------------------------------------------------------}
 
--- | Number of buckets in a routing table.
-type BucketCount = Int
-
-defaultBucketCount :: BucketCount
+defaultBucketCount :: Int
 defaultBucketCount = 20
 
-data Info dht ip u = Info
-    { myBuckets :: Table dht ip u
-    , myNodeId :: NodeId dht
+data Info ni nid = Info
+    { myBuckets :: Table ni nid
+    , myNodeId :: nid
     , myAddress :: SockAddr
     }
  deriving Generic
 
-deriving instance (Eq ip, Eq u, Eq (NodeId dht)) => Eq (Info dht ip u)
-deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Info dht ip u)
+deriving instance (Eq ni, Eq nid) => Eq (Info ni nid)
+deriving instance (Show ni, Show nid) => Show (Info ni nid)
 
 -- instance (Eq ip, Serialize ip) => Serialize (Info ip)
 
@@ -351,33 +344,41 @@ deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Info dht ip u)
 -- is always split into two new buckets covering the ranges @0..2 ^
 -- 159@ and @2 ^ 159..2 ^ 160@.
 --
-data Table dht ip u
+data Table ni nid
   -- most nearest bucket
-  = Tip  (NodeId dht) BucketCount (Bucket dht ip u)
+  = Tip  nid Int (Bucket ni)
 
   -- left biased tree branch
-  | Zero (Table dht ip u) (Bucket dht ip u)
+  | Zero (Table ni nid) (Bucket ni)
 
   -- right biased tree branch
-  | One  (Bucket dht ip u) (Table dht ip u)
+  | One  (Bucket ni) (Table ni nid)
     deriving Generic
 
-instance (Eq ip, Eq (NodeId dht)) => Eq (Table dht ip u) where
+instance (Eq ni, Eq nid) => Eq (Table ni nid) where
   (==) = (==) `on` Network.DHT.Routing.toList
 
+#if 0
+
 instance Serialize NominalDiffTime where
   put = putWord32be . fromIntegral   . fromEnum
   get = (toEnum     . fromIntegral) <$> getWord32be
 
-deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Table dht ip u)
+#endif
+
+deriving instance (Show ni, Show nid) => Show (Table ni nid)
+
+#if 0
 
 -- | Normally, routing table should be saved between invocations of
 -- the client software. Note that you don't need to store /this/
 -- 'NodeId' since it is already included in routing table.
-instance (Eq ip, Serialize ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize u) => Serialize (Table dht ip u)
+instance (Eq ip, Serialize ip, Ord (NodeId), Serialize (NodeId), Serialize u) => Serialize (Table)
+
+#endif
 
 -- | Shape of the table.
-instance Pretty (Table dht ip u) where
+instance Pretty (Table ni nid) where
   pPrint t
     | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss
     |    otherwise    = brackets $
@@ -388,26 +389,28 @@ instance Pretty (Table dht ip u) where
       ss = shape t
 
 -- | Empty table with specified /spine/ node id.
-nullTable :: Eq ip => NodeId dht -> BucketCount -> Table dht ip u
+nullTable :: nid -> Int -> Table ni nid
 nullTable nid n = Tip nid (bucketCount (pred n)) (Bucket PSQ.empty (runIdentity $ emptyQueue bucketQ))
   where
     bucketCount x = max 0 (min 159 x)
 
+#if 0
+
 -- | Test if table is empty. In this case DHT should start
 -- bootstrapping process until table becomes 'full'.
-null :: Table dht ip u -> Bool
+null :: Table -> Bool
 null (Tip _ _ b) = PSQ.null $ bktNodes b
 null  _          = False
 
 -- | Test if table have maximum number of nodes. No more nodes can be
 -- 'insert'ed, except old ones becomes bad.
-full :: Table dht ip u -> Bool
+full :: Table -> Bool
 full (Tip  _ n _) = n == 0
 full (Zero   t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t
 full (One    b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t
 
 -- | Get the /spine/ node id.
-thisId :: Table dht ip u -> NodeId dht
+thisId :: Table -> NodeId
 thisId (Tip  nid _ _) = nid
 thisId (Zero table _) = thisId table
 thisId (One _  table) = thisId table
@@ -415,21 +418,25 @@ thisId (One _  table) = thisId table
 -- | Number of nodes in a bucket or a table.
 type NodeCount   = Int
 
+#endif
+
 -- | Internally, routing table is similar to list of buckets or a
 -- /matrix/ of nodes. This function returns the shape of the matrix.
-shape :: Table dht ip u -> [BucketSize]
+shape :: Table ni nid -> [Int]
 shape = map (PSQ.size . bktNodes) . toBucketList
 
+#if 0
+
 -- | Get number of nodes in the table.
-size :: Table dht ip u -> NodeCount
+size :: Table -> NodeCount
 size = L.sum . shape
 
 -- | Get number of buckets in the table.
-depth :: Table dht ip u -> BucketCount
+depth :: Table -> BucketCount
 depth = L.length . shape
 
-lookupBucket :: ( FiniteBits (NodeId dht)
-                ) => NodeId dht -> Table dht ip u -> [Bucket dht ip u]
+lookupBucket :: ( FiniteBits (NodeId)
+                ) => NodeId -> Table -> [Bucket]
 lookupBucket nid = go 0 []
   where
     go i bs (Zero table bucket)
@@ -440,18 +447,19 @@ lookupBucket nid = go 0 []
       |     otherwise        = bucket : toBucketList table ++ bs
     go _ bs (Tip _ _ bucket) = bucket : bs
 
-compatibleNodeId :: forall dht ip u.
-                    ( Serialize (NodeId dht)
-                    , FiniteBits (NodeId dht)
-                    ) => Table dht ip u -> IO (NodeId dht)
+#endif
+
+compatibleNodeId :: forall ni nid.
+                    ( Serialize nid, FiniteBits nid) =>
+                    Table ni nid -> IO nid
 compatibleNodeId tbl = genBucketSample prefix br
  where
     br = bucketRange (L.length (shape tbl) - 1) True
-    nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8
+    nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
     bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0
     prefix = either error id $ S.decode bs
 
-tablePrefix :: Table dht ip u -> [Word8]
+tablePrefix :: Table ni nid -> [Word8]
 tablePrefix = map (packByte . take 8 . (++repeat False))
               . chunksOf 8
               . tableBits
@@ -460,7 +468,7 @@ tablePrefix = map (packByte . take 8 . (++repeat False))
     bitmask ix True = bit ix
     bitmask _  _    = 0
 
-tableBits :: Table dht ip u -> [Bool]
+tableBits :: Table ni nid -> [Bool]
 tableBits (One _ tbl)  = True : tableBits tbl
 tableBits (Zero tbl _) = False : tableBits tbl
 tableBits (Tip _ _ _)  = []
@@ -474,6 +482,9 @@ chunksOf i ls = map (take i) (build (splitter ls)) where
 build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
 build g = g (:) []
 
+#if 0
+
+
 -- | Count of closest nodes in find_node request.
 type K = Int
 
@@ -482,17 +493,17 @@ defaultK :: K
 defaultK = 8
 
 class TableKey dht k where
-  toNodeId :: k -> NodeId dht
+  toNodeId :: k -> NodeId
 
-instance TableKey dht (NodeId dht) where
+instance TableKey dht (NodeId) where
   toNodeId = id
 
 -- | Get a list of /K/ closest nodes using XOR metric. Used in
 -- 'find_node' and 'get_peers' queries.
 kclosest :: ( Eq ip
-            , Ord (NodeId dht)
-            , FiniteBits (NodeId dht)
-            ) => TableKey dht a => K -> a -> Table dht ip u -> [NodeInfo dht ip u]
+            , Ord (NodeId)
+            , FiniteBits (NodeId)
+            ) => TableKey dht a => K -> a -> Table -> [NodeInfo]
 kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket)
                                           ++ rank nodeId nid (L.concat everyone)
  where
@@ -502,19 +513,22 @@ kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket)
         . lookupBucket nid
         $ tbl
 
+#endif
+
 {-----------------------------------------------------------------------
 --  Routing
 -----------------------------------------------------------------------}
 
-splitTip :: ( Eq ip
-            , Ord (NodeId dht)
-            , FiniteBits (NodeId dht)
-            ) => NodeId dht -> BucketCount -> BitIx -> Bucket dht ip u -> Table dht ip u
-splitTip nid n i bucket
+splitTip :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
+            Ord ni =>
+            (nid -> Word -> Bool)
+            -> (ni -> Word -> Bool)
+            -> nid -> Int -> BitIx -> Bucket ni -> Table ni nid
+splitTip testIdBit testNodeBit nid n i bucket
   | testIdBit nid i = (One  zeros (Tip nid (pred n) ones))
   |    otherwise    = (Zero (Tip nid (pred n) zeros) ones)
   where
-    (ones, zeros) = split i bucket
+    (ones, zeros) = split testNodeBit i bucket
 
 -- | Used in each query.
 --
@@ -522,15 +536,14 @@ splitTip nid n i bucket
 -- k nodes in them.  Which subtrees I mean is illustrated in Fig 1. of Kademlia
 -- paper.  The rule requiring additional splits is in section 2.4.
 modifyBucket
-  :: forall xs dht ip u.
-     ( Eq ip
-     , Ord (NodeId dht)
-     , FiniteBits (NodeId dht)
-     ) =>
-     NodeId dht -> (Bucket dht ip u -> Maybe (xs, Bucket dht ip u)) -> Table dht ip u -> Maybe (xs,Table dht ip u)
-modifyBucket nodeId f = go (0 :: BitIx)
+  :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
+    forall ni nid xs. Ord ni =>
+    (nid -> Word -> Bool)
+    -> (ni -> Word -> Bool)
+    -> nid -> (Bucket ni -> Maybe (xs, Bucket ni)) -> Table ni nid -> Maybe (xs,Table ni nid)
+modifyBucket testIdBit testNodeBit nodeId f = go (0 :: BitIx)
   where
-    go :: BitIx -> Table dht ip u -> Maybe (xs, Table dht ip u)
+    go :: BitIx -> Table ni nid -> Maybe (xs, Table ni nid)
     go !i (Zero table  bucket)
       | testIdBit nodeId i  = second (Zero  table) <$> f bucket
       |     otherwise       = second (`Zero` bucket) <$> go (succ i) table
@@ -540,56 +553,65 @@ modifyBucket nodeId f = go (0 :: BitIx)
     go !i (Tip nid n bucket)
       |        n == 0       = second (Tip nid n)    <$> f bucket
       |     otherwise       = second (Tip nid n)    <$> f bucket
-                           <|>  go i (splitTip nid n i bucket)
+                           <|>  go i (splitTip testIdBit testNodeBit nid n i bucket)
+
 
 -- | Triggering event for atomic table update
-data Event dht ip u = TryInsert { foreignNode :: NodeInfo dht ip u }
-                    | PingResult { foreignNode :: NodeInfo dht ip u
-                                 , ponged :: Bool
-                                 }
-deriving instance Eq (NodeId dht) => Eq (Event dht ip u)
+data Event ni = TryInsert  { foreignNode :: ni }
+              | PingResult { foreignNode :: ni , ponged :: Bool }
+
+#if 0
+deriving instance Eq (NodeId) => Eq (Event)
 deriving instance ( Show ip
-                  , Show (NodeId dht)
+                  , Show (NodeId)
                   , Show u
-                  ) => Show (Event dht ip u)
+                  ) => Show (Event)
+
+#endif
+
+eventId :: (ni -> nid) -> Event ni -> nid
+eventId nodeId (TryInsert ni)    = nodeId ni
+eventId nodeId (PingResult ni _) = nodeId ni
 
-eventId :: Event dht ip u -> NodeId dht
-eventId (TryInsert NodeInfo{..})    = nodeId
-eventId (PingResult NodeInfo{..} _) = nodeId
 
 -- | Actions requested by atomic table update
-data CheckPing dht ip u = CheckPing [NodeInfo dht ip u]
+data CheckPing ni = CheckPing [ni]
+
+#if 0
 
-deriving instance Eq (NodeId dht) => Eq (CheckPing dht ip u)
+deriving instance Eq (NodeId) => Eq (CheckPing)
 deriving instance ( Show ip
-                  , Show (NodeId dht)
+                  , Show (NodeId)
                   , Show u
-                  ) => Show (CheckPing dht ip u)
+                  ) => Show (CheckPing)
 
+#endif
 
 -- | Atomic 'Table' update
-insert :: ( Eq ip
-          , Applicative m
-          , Ord (NodeId dht)
-          , FiniteBits (NodeId dht)
-          ) => Timestamp -> Event dht ip u -> Table dht ip u -> m ([CheckPing dht ip u], Table dht ip u)
-insert tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket (eventId event) (insertBucket tm event) tbl
+insert :: -- ( Eq ip , Applicative m , Ord (NodeId) , FiniteBits (NodeId)) =>
+    (Applicative m, Ord ni) =>
+    (nid -> Word -> Bool)
+    -> (ni -> nid)
+    -> Timestamp -> Event ni -> Table ni nid -> m ([CheckPing ni], Table ni nid)
+insert testIdBit nodeId tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket testIdBit (\ni -> testIdBit $ nodeId ni) (eventId nodeId event) (insertBucket tm event) tbl
+
 
 
 {-----------------------------------------------------------------------
 --  Conversion
 -----------------------------------------------------------------------}
 
-type TableEntry dht ip u = (NodeInfo dht ip u, Timestamp)
+type TableEntry ni = (ni, Timestamp)
 
-tableEntry :: NodeEntry dht ip u -> TableEntry dht ip u
+tableEntry :: NodeEntry ni -> TableEntry ni
 tableEntry (a :-> b) = (a, b)
 
 -- | Non-empty list of buckets.
-toBucketList :: Table dht ip u -> [Bucket dht ip u]
+toBucketList :: Table ni nid -> [Bucket ni]
 toBucketList (Tip _ _ b) = [b]
 toBucketList (Zero  t b) = b : toBucketList t
 toBucketList (One   b t) = b : toBucketList t
 
-toList :: Eq ip => Table dht ip u -> [[TableEntry dht ip u]]
+toList :: Table ni nid -> [[TableEntry ni]]
 toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList
+