-- | -- Copyright : (c) Sam Truzjan 2013 -- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental -- Portability : portable -- -- Every node maintains a routing table of known good nodes. The -- nodes in the routing table are used as starting points for -- queries in the DHT. Nodes from the routing table are returned in -- response to queries from other nodes. -- -- For more info see: -- -- {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.DHT.Routing {- ( -- * Table Table , Info(..) -- * Attributes , BucketCount , defaultBucketCount , BucketSize , defaultBucketSize , NodeCount -- * Query , Network.DHT.Routing.null , Network.DHT.Routing.full , thisId , shape , Network.DHT.Routing.size , Network.DHT.Routing.depth , compatibleNodeId -- * Lookup , K , defaultK , TableKey (..) , kclosest -- * Construction , Network.DHT.Routing.nullTable , Event(..) , CheckPing(..) , Network.DHT.Routing.insert -- * Conversion , Network.DHT.Routing.TableEntry , Network.DHT.Routing.toList -- * Routing , Timestamp , getTimestamp ) -} where import Control.Applicative as A import Control.Arrow import Control.Monad import Data.Function import Data.Functor.Identity import Data.List as L hiding (insert) import Data.Maybe import Data.Monoid import Data.Wrapper.PSQ as PSQ import Data.Serialize as S hiding (Result, Done) import qualified Data.Sequence as Seq import Data.Time import Data.Time.Clock.POSIX import Data.Word import GHC.Generics import Text.PrettyPrint as PP hiding ((<>)) import Text.PrettyPrint.HughesPJClass (pPrint,Pretty) import qualified Data.ByteString as BS import Data.Bits import Data.Ord import Network.Address -- | Last time the node was responding to our queries. -- -- Not all nodes that we learn about are equal. Some are \"good\" and -- some are not. Many nodes using the DHT are able to send queries -- and receive responses, but are not able to respond to queries -- from other nodes. It is important that each node's routing table -- must contain only known good nodes. A good node is a node has -- responded to one of our queries within the last 15 minutes. A -- node is also good if it has ever responded to one of our queries -- and has sent us a query within the last 15 minutes. After 15 -- minutes of inactivity, a node becomes questionable. Nodes become -- bad when they fail to respond to multiple queries in a row. Nodes -- that we know are good are given priority over nodes with unknown -- status. -- type Timestamp = POSIXTime getTimestamp :: IO Timestamp getTimestamp = do utcTime <- getCurrentTime return $ utcTimeToPOSIXSeconds utcTime {----------------------------------------------------------------------- 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 -- PINGed. If the node is found to be still alive, the new node is -- place in a secondary list, a replacement cache. The replacement -- cache is used only if a node in the k-bucket stops responding. In -- other words: new nodes are used only when older nodes disappear. -- | Timestamp - last time this node is pinged. type NodeEntry ni = Binding ni Timestamp -- | Maximum number of 'NodeInfo's stored in a bucket. Most clients -- use this value. defaultBucketSize :: Int defaultBucketSize = 8 data QueueMethods m elem fifo = QueueMethods { pushBack :: elem -> fifo -> m fifo , popFront :: fifo -> m (Maybe elem, fifo) , emptyQueue :: m fifo } {- fromQ :: Functor m => ( a -> b ) -> ( b -> a ) -> QueueMethods m elem a -> QueueMethods m elem b fromQ embed project QueueMethods{..} = QueueMethods { pushBack = \e -> fmap embed . pushBack e . project , popFront = fmap (second embed) . popFront . project , emptyQueue = fmap embed emptyQueue } -} seqQ :: QueueMethods Identity ni (Seq.Seq ni) seqQ = QueueMethods { pushBack = \e fifo -> pure (fifo Seq.|> e) , popFront = \fifo -> case Seq.viewl fifo of e Seq.:< fifo' -> pure (Just e, fifo') Seq.EmptyL -> pure (Nothing, Seq.empty) , emptyQueue = pure Seq.empty } type BucketQueue ni = Seq.Seq ni 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 -- table tree. Size of the bucket should be choosen such that it's -- very unlikely that all nodes in bucket fail within an hour of -- each other. -- data Bucket ni = Bucket { bktNodes :: !(PSQ ni Timestamp) , bktQ :: !(BucketQueue ni) } deriving Generic deriving instance Show ni => Show (Bucket ni) #if 0 {- getGenericNode :: ( Serialize (NodeId) , Serialize ip , Serialize u ) => Get (NodeInfo) getGenericNode = do nid <- get naddr <- get u <- get return NodeInfo { nodeId = nid , nodeAddr = naddr , nodeAnnotation = u } putGenericNode :: ( Serialize (NodeId) , Serialize ip , Serialize u ) => NodeInfo -> Put putGenericNode (NodeInfo nid naddr u) = do put nid put naddr put u 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 psqToPairList :: OrdPSQ t t1 () -> [(t, t1)] psqToPairList psq = map (\(a :-> b) -> (a,b)) $ PSQ.toList psq -- | Update interval, in seconds. delta :: NominalDiffTime delta = 15 * 60 -- | Should maintain a set of stable long running nodes. -- -- Note: pings are triggerd only when a bucket is full. 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 = pure ( [], map_ns $ PSQ.insertWith max info curTime ) -- bucket is good, but not full => we can insert a new node | PSQ.size (bktNodes bucket) < defaultBucketSize = pure ( [], map_ns $ PSQ.insert info curTime ) -- If there are any questionable nodes in the bucket have not been -- seen in the last 15 minutes, the least recently seen node is -- pinged. If any nodes in the bucket are known to have become bad, -- then one is replaced by the new node in the next insertBucket -- iteration. | not (L.null stales) = pure ( [CheckPing stales] , bucket { -- Update timestamps so that we don't redundantly ping. bktNodes = updateStamps curTime stales $ bktNodes bucket -- Update queue with the pending NodeInfo in case of ping fail. , bktQ = runIdentity $ pushBack bucketQ info $ bktQ bucket } ) -- When the bucket is full of good nodes, the new node is simply discarded. -- We must return 'A.empty' here to ensure that bucket splitting happens -- inside 'modifyBucket'. | otherwise = A.empty where -- We (take 1) to keep a 1-to-1 correspondence between pending pings and -- waiting nodes in the bktQ. This way, we don't have to worry about what -- to do with failed pings for which there is no ready replacements. stales = -- One stale: do (n :-> t) <- maybeToList $ PSQ.findMin (bktNodes bucket) guard (t < curTime - delta) return n -- All stale: -- map key \$ PSQ.atMost (curTime - delta) $ bktNodes bucket already_have = maybe False (const True) $ PSQ.lookup info (bktNodes bucket) map_ns f = bucket { bktNodes = f (bktNodes bucket) } -- map_q f = bucket { bktQ = runIdentity \$ f (bktQ bucket) } insertBucket curTime (PingResult bad_node got_response) bucket = pure ([], Bucket (upd $ bktNodes bucket) popped) where (top, popped) = runIdentity $ popFront bucketQ (bktQ bucket) upd | got_response = id | Just info <- top = \nodes -> fromMaybe nodes $ do _ <- PSQ.lookup bad_node nodes -- Insert only if there's a removal. let nodes' = PSQ.delete bad_node nodes pure $ PSQ.insert info curTime nodes' | otherwise = id 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 partitionQ :: Monad f => QueueMethods f elem b -> (elem -> Bool) -> b -> f (b, b) partitionQ imp test q0 = do pass0 <- emptyQueue imp fail0 <- emptyQueue imp let flipfix a b f = fix f a b flipfix q0 (pass0,fail0) $ \rec q qs -> do (mb,q') <- popFront imp q case mb of Nothing -> return qs Just e -> do qs' <- select (pushBack imp e) qs rec q' qs' where select :: Functor f => (b -> f b) -> (b, b) -> f (b, b) select f = if test e then \(a,b) -> flip (,) b <$> f a else \(a,b) -> (,) a <$> f b 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 :: ni -> Bool spanBit entry = testNodeIdBit entry i {----------------------------------------------------------------------- -- Table -----------------------------------------------------------------------} defaultBucketCount :: Int defaultBucketCount = 20 data Info ni nid = Info { myBuckets :: Table ni nid , myNodeId :: nid , myAddress :: SockAddr } deriving Generic 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) -- | The routing table covers the entire 'NodeId' space from 0 to 2 ^ -- 160. The routing table is subdivided into 'Bucket's that each cover -- a portion of the space. An empty table has one bucket with an ID -- space range of @min = 0, max = 2 ^ 160@. When a node with ID \"N\" -- is inserted into the table, it is placed within the bucket that has -- @min <= N < max@. An empty table has only one bucket so any node -- must fit within it. Each bucket can only hold 'K' nodes, currently -- eight, before becoming 'Full'. When a bucket is full of known good -- nodes, no more nodes may be added unless our own 'NodeId' falls -- within the range of the 'Bucket'. In that case, the bucket is -- replaced by two new buckets each with half the range of the old -- bucket and the nodes from the old bucket are distributed among the -- two new ones. For a new table with only one bucket, the full bucket -- is always split into two new buckets covering the ranges @0..2 ^ -- 159@ and @2 ^ 159..2 ^ 160@. -- data Table ni nid -- most nearest bucket = Tip nid Int (Bucket ni) -- left biased tree branch | Zero (Table ni nid) (Bucket ni) -- right biased tree branch | One (Bucket ni) (Table ni nid) deriving Generic 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 #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), Serialize (NodeId), Serialize u) => Serialize (Table) #endif -- | Shape of the table. instance Pretty (Table ni nid) where pPrint t | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss | otherwise = brackets $ PP.int (L.sum ss) <> " nodes, " <> PP.int bucketCount <> " buckets" where bucketCount = L.length ss ss = shape t -- | Empty table with specified /spine/ node id. 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 -> 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 -> 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 -> NodeId thisId (Tip nid _ _) = nid thisId (Zero table _) = thisId table 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 ni nid -> [Int] shape = map (PSQ.size . bktNodes) . toBucketList #if 0 -- | Get number of nodes in the table. size :: Table -> NodeCount size = L.sum . shape -- | Get number of buckets in the table. depth :: Table -> BucketCount depth = L.length . shape #endif lookupBucket :: ( FiniteBits nid , Ord nid ) => nid -> Table ni nid -> [Bucket ni] lookupBucket nid = go 0 [] where go i bs (Zero table bucket) | testIdBit nid i = bucket : toBucketList table ++ bs | otherwise = go (succ i) (bucket:bs) table go i bs (One bucket table) | testIdBit nid i = go (succ i) (bucket:bs) table | otherwise = bucket : toBucketList table ++ bs go _ bs (Tip _ _ bucket) = bucket : bs 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 :: nid) `div` 8 bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0 prefix = either error id $ S.decode bs tablePrefix :: Table ni nid -> [Word8] tablePrefix = map (packByte . take 8 . (++repeat False)) . chunksOf 8 . tableBits where packByte = foldl1' (.|.) . zipWith bitmask [7,6 .. 0] bitmask ix True = bit ix bitmask _ _ = 0 tableBits :: Table ni nid -> [Bool] tableBits (One _ tbl) = True : tableBits tbl tableBits (Zero tbl _) = False : tableBits tbl tableBits (Tip _ _ _) = [] chunksOf :: Int -> [e] -> [[e]] chunksOf i ls = map (take i) (build (splitter ls)) where splitter :: [e] -> ([e] -> a -> a) -> a -> a splitter [] _ n = n splitter l c n = l `c` splitter (drop i l) c n build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build g = g (:) [] #if 0 -- | Count of closest nodes in find_node request. type K = Int -- | Default 'K' is equal to 'defaultBucketSize'. defaultK :: K defaultK = 8 class TableKey dht k where toNodeId :: k -> NodeId instance TableKey dht (NodeId) where toNodeId = id #endif -- | In Kademlia, the distance metric is XOR and the result is -- interpreted as an unsigned integer. newtype NodeDistance nodeid = NodeDistance nodeid deriving (Eq, Ord) -- | distance(A,B) = |A xor B| Smaller values are closer. distance :: Bits nid => nid -> nid -> NodeDistance nid distance a b = NodeDistance $ xor a b -- | Order by closeness: nearest nodes first. rank :: ( FiniteBits nid , Ord nid ) => (x -> nid) -> nid -> [x] -> [x] rank f nid = L.sortBy (comparing (distance nid . f)) -- | Get a list of /K/ closest nodes using XOR metric. Used in -- 'find_node' and 'get_peers' queries. kclosest :: ( FiniteBits nid , Ord nid ) => (ni -> nid) -> Int -> nid -> Table ni nid -> [ni] kclosest nodeId k nid tbl = take k $ rank nodeId nid (L.concat bucket) ++ rank nodeId nid (L.concat everyone) where (bucket,everyone) = L.splitAt 1 . L.map (L.map PSQ.key . PSQ.toList . bktNodes) . lookupBucket nid $ tbl {----------------------------------------------------------------------- -- Routing -----------------------------------------------------------------------} 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 testNodeBit i bucket -- | Used in each query. -- -- TODO: Kademlia non-empty subtrees should should split if they have less than -- 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 :: -- ( 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 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 go !i (One bucket table ) | testIdBit nodeId i = second (One bucket) <$> go (succ i) table | otherwise = second (`One` table) <$> f bucket go !i (Tip nid n bucket) | n == 0 = second (Tip nid n) <$> f bucket | otherwise = second (Tip nid n) <$> f bucket <|> go i (splitTip testIdBit testNodeBit nid n i bucket) -- | Triggering event for atomic table update 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) , Show u ) => Show (Event) #endif eventId :: (ni -> nid) -> Event ni -> nid eventId nodeId (TryInsert ni) = nodeId ni eventId nodeId (PingResult ni _) = nodeId ni -- | Actions requested by atomic table update data CheckPing ni = CheckPing [ni] #if 0 deriving instance Eq (NodeId) => Eq (CheckPing) deriving instance ( Show ip , Show (NodeId) , Show u ) => Show (CheckPing) #endif -- | Atomic 'Table' update 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 ni = (ni, Timestamp) tableEntry :: NodeEntry ni -> TableEntry ni tableEntry (a :-> b) = (a, b) -- | Non-empty list of buckets. 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 :: Table ni nid -> [[TableEntry ni]] toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList