From adc30fe62736d1f4f539a971db681b0a5c552871 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 13 Jul 2017 18:42:20 -0400 Subject: Removed type argument clutter from Routing table. --- src/Network/DHT/Routing.hs | 264 +++++++++++++++++++----------------- src/Network/DatagramServer/Types.hs | 16 +-- 2 files changed, 151 insertions(+), 129 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 + diff --git a/src/Network/DatagramServer/Types.hs b/src/Network/DatagramServer/Types.hs index 6aa7aeaa..68aa9212 100644 --- a/src/Network/DatagramServer/Types.hs +++ b/src/Network/DatagramServer/Types.hs @@ -326,25 +326,25 @@ genNodeId = either error id . S.decode <$> getEntropy nodeIdSize -- is for the current deepest bucket in our routing table: -- -- > sample <- genBucketSample nid (bucketRange index is_last) -genBucketSample :: ( FiniteBits (NodeId dht) - , Serialize (NodeId dht) - ) => NodeId dht -> (Int,Word8,Word8) -> IO (NodeId dht) +genBucketSample :: ( FiniteBits nid + , Serialize nid + ) => nid -> (Int,Word8,Word8) -> IO nid genBucketSample n qmb = genBucketSample' getEntropy n qmb -- | Generalizion of 'genBucketSample' that accepts a byte generator -- function to use instead of the system entropy. -genBucketSample' :: forall m dht. +genBucketSample' :: forall m dht nid. ( Applicative m - , FiniteBits (NodeId dht) - , Serialize (NodeId dht) + , FiniteBits nid + , Serialize nid ) => - (Int -> m ByteString) -> NodeId dht -> (Int,Word8,Word8) -> m (NodeId dht) + (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid genBucketSample' gen self (q,m,b) | q <= 0 = either error id . S.decode <$> gen nodeIdSize | q >= nodeIdSize = pure self | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1) where - nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8 + nodeIdSize = finiteBitSize (undefined :: nid) `div` 8 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl) where hd = BS.take q $ S.encode self -- cgit v1.2.3