diff options
-rw-r--r-- | Kademlia.hs | 32 | ||||
-rw-r--r-- | src/Network/DHT/Routing.hs | 42 |
2 files changed, 49 insertions, 25 deletions
diff --git a/Kademlia.hs b/Kademlia.hs index 40874078..7bffe4c1 100644 --- a/Kademlia.hs +++ b/Kademlia.hs | |||
@@ -111,15 +111,6 @@ contramapIR f ir = InsertionReporter | |||
111 | , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b | 111 | , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b |
112 | } | 112 | } |
113 | 113 | ||
114 | data KademliaSpace nid ni = KademliaSpace | ||
115 | { kademliaLocation :: ni -> nid | ||
116 | , kademliaTestBit :: nid -> Word -> Bool | ||
117 | } | ||
118 | |||
119 | contramapKS f ks = ks | ||
120 | { kademliaLocation = kademliaLocation ks . f | ||
121 | } | ||
122 | |||
123 | -- | All the IO operations neccessary to maintain a Kademlia routing table. | 114 | -- | All the IO operations neccessary to maintain a Kademlia routing table. |
124 | data TableStateIO nid ni = TableStateIO | 115 | data TableStateIO nid ni = TableStateIO |
125 | { -- | Write the routing table. Typically 'writeTVar'. | 116 | { -- | Write the routing table. Typically 'writeTVar'. |
@@ -145,10 +136,29 @@ data TableStateIO nid ni = TableStateIO | |||
145 | , tblChanged :: RoutingTableChanged ni -> STM (IO ()) | 136 | , tblChanged :: RoutingTableChanged ni -> STM (IO ()) |
146 | } | 137 | } |
147 | 138 | ||
139 | vanillaIO :: TVar (Table ni nid) -> (ni -> IO Bool) -> TableStateIO nid ni | ||
140 | vanillaIO var ping = TableStateIO | ||
141 | { tblRead = readTVar var | ||
142 | , tblWrite = writeTVar var | ||
143 | , tblPing = ping | ||
144 | , tblChanged = const $ return $ return () | ||
145 | } | ||
146 | |||
147 | -- | Everything neccessary to maintain a routing table of /ni/ (node | ||
148 | -- information) entries. | ||
148 | data Kademlia nid ni = Kademlia (InsertionReporter ni) | 149 | data Kademlia nid ni = Kademlia (InsertionReporter ni) |
149 | (KademliaSpace nid ni) | 150 | (KademliaSpace nid ni) |
150 | (TableStateIO nid ni) | 151 | (TableStateIO nid ni) |
151 | 152 | ||
153 | {- | ||
154 | kademlia :: FiniteBits nid => | ||
155 | TVar (Table nid nid) -> (nid -> IO Bool) -> Kademlia nid nid | ||
156 | kademlia var ping = Kademlia quietInsertions | ||
157 | (KademliaSpace id testIdBit) | ||
158 | (vanillaIO var ping) | ||
159 | |||
160 | -} | ||
161 | |||
152 | insertNode :: | 162 | insertNode :: |
153 | forall ni nid. Ord ni => | 163 | forall ni nid. Ord ni => |
154 | Kademlia nid ni | 164 | Kademlia nid ni |
@@ -160,7 +170,7 @@ insertNode (Kademlia reporter space io) node = do | |||
160 | 170 | ||
161 | (ps,reaction) <- atomically $ do | 171 | (ps,reaction) <- atomically $ do |
162 | tbl <- tblRead io | 172 | tbl <- tblRead io |
163 | let (inserted, ps,t') = R.updateForInbound (kademliaTestBit space) (kademliaLocation space) tm node tbl | 173 | let (inserted, ps,t') = R.updateForInbound space tm node tbl |
164 | tblWrite io t' | 174 | tblWrite io t' |
165 | reaction <- if inserted | 175 | reaction <- if inserted |
166 | then tblChanged io $ RoutingTableChanged Nothing node tm | 176 | then tblChanged io $ RoutingTableChanged Nothing node tm |
@@ -177,7 +187,7 @@ insertNode (Kademlia reporter space io) node = do | |||
177 | reportPingResult reporter tm n b | 187 | reportPingResult reporter tm n b |
178 | join $ atomically $ do | 188 | join $ atomically $ do |
179 | tbl <- tblRead io | 189 | tbl <- tblRead io |
180 | let (replacements, t') = R.updateForPingResult (kademliaTestBit space) (kademliaLocation space) n b tbl | 190 | let (replacements, t') = R.updateForPingResult space n b tbl |
181 | tblWrite io t' | 191 | tblWrite io t' |
182 | sequence <$> mapM (\(x,(t,y)) -> tblChanged io $ RoutingTableChanged (Just x) y t) | 192 | sequence <$> mapM (\(x,(t,y)) -> tblChanged io $ RoutingTableChanged (Just x) y t) |
183 | replacements | 193 | replacements |
diff --git a/src/Network/DHT/Routing.hs b/src/Network/DHT/Routing.hs index 7f0e1c94..e2bc5aa9 100644 --- a/src/Network/DHT/Routing.hs +++ b/src/Network/DHT/Routing.hs | |||
@@ -638,33 +638,33 @@ deriving instance ( Show ip | |||
638 | -- [ /tbl'/ ] The updated routing 'Table'. | 638 | -- [ /tbl'/ ] The updated routing 'Table'. |
639 | -- | 639 | -- |
640 | updateForInbound :: Ord ni => | 640 | updateForInbound :: Ord ni => |
641 | (nid -> Word -> Bool) | 641 | KademliaSpace nid ni |
642 | -> (ni -> nid) | ||
643 | -> Timestamp -> ni -> Table ni nid -> (Bool, [ni], Table ni nid) | 642 | -> Timestamp -> ni -> Table ni nid -> (Bool, [ni], Table ni nid) |
644 | updateForInbound testIdBit nodeId tm ni tbl = | 643 | updateForInbound space tm ni tbl = |
645 | maybe (False, [],tbl) (\(ps,tbl') -> (True, ps, tbl')) | 644 | maybe (False, [],tbl) (\(ps,tbl') -> (True, ps, tbl')) |
646 | $ modifyBucket testIdBit (\ni -> testIdBit $ nodeId ni) | 645 | $ modifyBucket (kademliaTestBit space) |
647 | (nodeId ni) | 646 | (\ni -> kademliaTestBit space $ kademliaLocation space ni) |
648 | (updateBucketForInbound tm ni) | 647 | (kademliaLocation space ni) |
649 | tbl | 648 | (updateBucketForInbound tm ni) |
649 | tbl | ||
650 | 650 | ||
651 | -- | Update the routing table with the results of a ping. | 651 | -- | Update the routing table with the results of a ping. |
652 | -- | 652 | -- |
653 | -- Each (a,(tm,b)) in the returned list indicates that the node /a/ was deleted from the | 653 | -- Each (a,(tm,b)) in the returned list indicates that the node /a/ was deleted from the |
654 | -- routing table and the node /b/, with timestamp /tm/, has taken its place. | 654 | -- routing table and the node /b/, with timestamp /tm/, has taken its place. |
655 | updateForPingResult :: Ord ni => | 655 | updateForPingResult :: Ord ni => |
656 | (nid -> Word -> Bool) | 656 | KademliaSpace nid ni |
657 | -> (ni -> nid) | ||
658 | -> ni -- ^ The pinged node. | 657 | -> ni -- ^ The pinged node. |
659 | -> Bool -- ^ True if we got a reply, False if it timed out. | 658 | -> Bool -- ^ True if we got a reply, False if it timed out. |
660 | -> Table ni nid -- ^ The routing table. | 659 | -> Table ni nid -- ^ The routing table. |
661 | -> ( [(ni,(Timestamp, ni))], Table ni nid ) | 660 | -> ( [(ni,(Timestamp, ni))], Table ni nid ) |
662 | updateForPingResult testIdBit nodeId ni got_reply tbl = | 661 | updateForPingResult space ni got_reply tbl = |
663 | fromMaybe ([],tbl) | 662 | fromMaybe ([],tbl) |
664 | $ modifyBucket testIdBit (\ni -> testIdBit $ nodeId ni) | 663 | $ modifyBucket (kademliaTestBit space) |
665 | (nodeId ni) | 664 | (\ni -> kademliaTestBit space $ kademliaLocation space ni) |
666 | (updateBucketForPingResult ni got_reply) | 665 | (kademliaLocation space ni) |
667 | tbl | 666 | (updateBucketForPingResult ni got_reply) |
667 | tbl | ||
668 | 668 | ||
669 | 669 | ||
670 | {----------------------------------------------------------------------- | 670 | {----------------------------------------------------------------------- |
@@ -685,3 +685,17 @@ toBucketList (One b t) = b : toBucketList t | |||
685 | toList :: Table ni nid -> [[TableEntry ni]] | 685 | toList :: Table ni nid -> [[TableEntry ni]] |
686 | toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList | 686 | toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList |
687 | 687 | ||
688 | data KademliaSpace nid ni = KademliaSpace | ||
689 | { -- | Given a node record (probably including IP address), yields a | ||
690 | -- kademlia xor-metric location. | ||
691 | kademliaLocation :: ni -> nid | ||
692 | -- | Used when comparing locations. This is similar to | ||
693 | -- 'Data.Bits.testBit' except that the ordering of bits is reversed, so | ||
694 | -- that 0 is the most significant bit. | ||
695 | , kademliaTestBit :: nid -> Word -> Bool | ||
696 | } | ||
697 | |||
698 | contramapKS f ks = ks | ||
699 | { kademliaLocation = kademliaLocation ks . f | ||
700 | } | ||
701 | |||