REBOL [ Title: "Basic Chord implementation" Purpose: { Implements a basic version of the Chord distributed lookup protocol. } Author: "Gabriele Santilli" EMail: giesse@rebol.it File: %chord.r License: { Copyright (c) 2005, Gabriele Santilli All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The name of Gabriele Santilli may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } Date: 28-Jan-2005 Version: 1.40.0 ; majorv.minorv.status ; status: 0: unfinished; 1: testing; 2: stable History: [ 7-Jan-2005 1.1.0 "History start" 7-Jan-2005 1.2.0 "in-interval?" 8-Jan-2005 1.3.0 "find-successor" 8-Jan-2005 1.4.0 "closest-preceding-node" 8-Jan-2005 1.5.0 "chord-create, chord-join; factored out remote-find-successor" 8-Jan-2005 1.6.0 "stabilize" 8-Jan-2005 1.7.0 "notify, fix-fingers, check-predecessor" 11-Jan-2005 1.8.0 "Implemented message handler, testing" 11-Jan-2005 1.9.0 "Added check to handler, testing" 17-Jan-2005 1.10.0 "Started to add some redundancy and validity checks" 18-Jan-2005 1.11.0 "Changed find-successor to iterative instead of recursive; preparing for NAT discovery/traversal" 18-Jan-2005 1.12.0 "Rewriting chord-join..." 21-Jan-2005 1.13.0 "Still working..." 24-Jan-2005 1.14.0 "Still working... (reverted to recursive for find-succ. thanks to new messaging.r; using relays.r)" 24-Jan-2005 1.15.0 "Finished rewriting. Testing." 24-Jan-2005 1.16.0 "Fixed minor bug" 24-Jan-2005 1.17.0 "Fixed missing )" 25-Jan-2005 1.18.0 "Fixed a number of bugs; added successor list" 26-Jan-2005 1.19.0 "Fixed a number of bugs; better relay handling (now handles relay failures)" 26-Jan-2005 1.20.0 "Fixed a bug in NOTIFY" 26-Jan-2005 1.21.0 "Added /KEEP to node-send-message, to use for relaying" 26-Jan-2005 1.22.0 "Successor list length now configurable, set to 4 for testing purposes" 26-Jan-2005 1.23.0 "NOTIFY now verifies the possible new predecessor" 26-Jan-2005 1.24.0 "Fixed NOTIFY" 26-Jan-2005 1.25.0 "Changed some debug prints (less verbose now)" 27-Jan-2005 1.26.0 "FIX-FINGERS disabled, testing successor list problems" 27-Jan-2005 1.27.0 "Trying harder to find new relays, little change to STABILIZE" 27-Jan-2005 1.28.0 "Testing" 27-Jan-2005 1.29.0 "Small change to find-successor handler" 27-Jan-2005 1.30.0 "Small change to node-send-message, to bypass send-message when needed" 27-Jan-2005 1.31.0 "Now tries to find a free port to listen to, too" 27-Jan-2005 1.32.0 "Debugging relays" 27-Jan-2005 1.33.0 "Fixed bug in node-send-message" 27-Jan-2005 1.34.0 "New relay handling, should work better now" 27-Jan-2005 1.35.0 "Fixed a bug in MAKE-NODE" 27-Jan-2005 1.36.0 "Small change to CHORD-JOIN" 27-Jan-2005 1.37.0 "NODE-RULE was too restrictive with the new changes" 27-Jan-2005 1.38.0 "Removed some debug prints" 28-Jan-2005 1.39.0 "Increased timeout in NODE-SEND-MESSAGE" 28-Jan-2005 1.40.0 "Trying to workaround a mysterious problem: added some DO-AFTERs" ] ] NODE-SEND-MESSAGE-RETRIES: 3 SUCCESSOR-LIST-MAXLENGTH: 6 in-interval?: func [ "Check if value is in interval" interval [block!] value /local start end gt? lt? mark ] [ ;print ["in-interval?" mold interval mold value] parse interval [ ['except (gt?: :greater?) | none (gt?: :greater-or-equal?)] mark: (set [start mark] do/next mark) :mark '.. ['except (lt?: :lesser?) | none (lt?: :lesser-or-equal?)] mark: (set [end mark] do/next mark) :mark ] either start <= end [ all [gt? value start lt? value end] ] [ any [gt? value start lt? value end] ] ] ; node! object node!: context [ self-words: bind copy next next first self 'self key: "The node's 160 bit key" node-id: "Virtual node ID" public-ip: "The node's public IP address" public-urls: "A list of URLs to reach the node" private-urls: "A list of URLs to reach the node from inside the LAN" name: "The node's name" relay: "The node's relay node, if any" ;coords: "Node coordinates" ] node-rule: [ binary! [integer! | none!] [tuple! | none!] into [any url!] into [any url!] string! [into node-rule | none!] ] block-to-node: func [block] [ make node! [set self-words block] ] node-to-block: func [node] [ copy/part next next second node length? node/self-words ] ; local node properties node!: make node! [ failures: 0 ; Node failures relay-obj: none ] my-successor: my-predecessor: myself: none successor-list: make block! 16 key-of: func [node] [node/key] url-of: func [node] [node/public-urls/1] pick-mod: func [block i] [ pick block i - 1 // (length? block) + 1 ] node-send-message: closure [node i message callback /keep /local cb url] [ do-after 0 [ catch [ ;debug true ["node-send-message" node/name i mold :message] url: either all [myself node/public-ip = myself/public-ip] [ node/private-urls ] [ node/public-urls ] if all [empty? url node/relay integer? node/node-id node/node-id > 0] [ node/relay-obj: any [node/relay-obj block-to-node node/relay] ;debug true ["Message needs relay:" mold :message "relay node:" node/relay-obj/name] node-send-message node/relay-obj 1 reduce [node/node-id :message] func [result] [ ;debug true ["!> node-send-message" node/name url mold :message "relay result:" mold :result] if none? result [ node/failures: node/failures + 1 either i < NODE-SEND-MESSAGE-RETRIES [ node-send-message node i + 1 message :callback ] [ callback none ] exit ] if all [block? result parse result ['error 'no-relay string!]] [ node/failures: 1000 callback none exit ] node/failures: max 0 node/failures - 1 callback result ] throw none ] url: pick-mod url i ;debug true [" url:" url] cb: func [result] [ ;debug true ["!> node-send-message" node/name url mold :message "result:" mold :result] if none? result [ node/failures: node/failures + 1 either i < NODE-SEND-MESSAGE-RETRIES [ node-send-message node i + 1 message :callback ] [ callback none ] exit ] if all [block? result parse result ['error 'no-handler string!]] [ node/failures: node/failures + 3 either i < NODE-SEND-MESSAGE-RETRIES [ node-send-message node i + 1 message :callback ] [ callback none ] exit ] node/failures: max 0 node/failures - 1 callback result ] if all [found? myself node/key = myself/key] [ ;debug true "Message seems to be for myself... using HANDLE-MESSAGE directly" handle-message none message :cb throw none ] either keep [ send-message/async/timeout url message :cb 0:05 ] [ send-message/async/timeout url message :cb 15 ] ] ] ] ; DEPENDENCY: utility.r remote-find-successor: closure [node key callback] [ ;debug true ["remote-find-successor" mold node/name mold key] node-send-message node 1 compose [find-successor (key)] func [result] [ ;debug true ["!> remote-find-succ internal callback:" mold result] either all [block? result parse result node-rule] [ callback block-to-node result ] [ callback none ] ] ] remote-find-successor': closure [nodes key callback] [ ;debug true ["remote-find-successor'" length? nodes mold key] if empty? nodes [callback none exit] remote-find-successor first nodes key func [result] [ ;debug true ["!> remote-find-succ' internal callback:" mold result] either object? result [ callback result ] [ do-after 0 [remote-find-successor' next nodes key :callback] ] ] ] find-successor: closure [key callback /local nodes] [ ;debug true ["find-successor" mold key] ; empty ring? if myself/key = my-successor/key [callback myself exit] if key = myself/key [callback myself exit] either in-interval? [except myself/key .. my-successor/key] key [ callback my-successor ] [ nodes: closest-preceding-nodes key either all [not empty? nodes key = nodes/1/key] [ callback nodes/1 ] [ remote-find-successor' nodes key :callback ] ] ] ; finger table in reverse order finger: array 159 closest-preceding-nodes: func [key /local element f result] [ f: head finger forall f [ element: first f if all [object? element in-interval? [except myself/key .. key] element/key] [ result: reduce [element] f: next f forall f [ if object? element: first f [insert tail result element] if 3 < length? result [return result] ] insert insert tail result my-successor successor-list return result ] ] append reduce [my-successor] successor-list ] make-node: func [id name' pubip puburls privurls relay'] [ make node! [ node-id: id public-ip: pubip public-urls: puburls private-urls: privurls name: name' either relay' [relay: node-to-block relay-obj: relay'] [relay: none] key: checksum/secure mold join public-urls [node-id if relay-obj [relay-obj/key]] ] ] chord-create: func [my-urls my-name bootstrap-nodes /local n] [ my-predecessor: none ; bootstrap nodes cannot be under NAT myself: make-node 0 my-name none my-urls my-urls none either empty? bootstrap-nodes [ ; only one bootstrap node (myself) my-successor: myself successor-list: make block! 16 ] [ my-successor: my-predecessor: make-node 0 first bootstrap-nodes none second bootstrap-nodes second bootstrap-nodes none successor-list: make block! 16 foreach [name urls] next next bootstrap-nodes [ n: make-node 0 name none urls urls none if in-interval? [except myself/key .. my-successor/key] n/key [ my-successor: n ] if in-interval? [except my-predecessor/key .. myself/key] n/key [ my-predecessor: n ] ] ] print "Created:" print ["Myself:" myself/name] print ["My successor:" my-successor/name] print ["My predecessor:" my-predecessor/name] do-every 11 [stabilize check-predecessor true] ;do-every 7 [fix-fingers true] ] random-key: does [ checksum/secure random/secure mold system/standard ] find-my-ips: closure [bootstrap-urls callback /local port public private] [ port: make port! first bootstrap-urls bootstrap-urls: next bootstrap-urls send-message/async port [what is my ip?] func [result] [ if find [ahttp ahttps] port/scheme [ private: port/sub-port/sub-port/local-ip ] if block? result [parse result ['your 'ip 'is set public tuple!]] either any [public tail? bootstrap-urls] [ callback public private ] [ do-after 0 [find-my-ips bootstrap-urls :callback] ] ] ] find-reachable-ports: closure [bootstrap-urls public-ip private-ip port-list callback /local h reachable ok? timeout-action publist privlist p] [ publist: make block! 16 privlist: make block! 16 foreach port-id port-list [ if not error? try [listen-messages/async join tcp://: port-id] [ ;print ["Listening on" port-id] insert tail privlist join ahttp:// [private-ip ":" port-id] ] ] ; try to listen on a random free port, too attempt [ p: open/direct/binary/no-wait tcp://:0 listen-messages/async p insert tail privlist join ahttp:// [private-ip ":" p/port-id] port-list: join port-list p/port-id ] reachable: make block! 16 ok?: no insert handlers h: func [port message callback] [ ;print ["Gotcha handler:" mold message] either all [port? port message = [gotcha]] [ ;print "They got us!" insert tail reachable port/local-port if not ok? [ ;print "At least one port reachable!" ok?: yes remove-timer timeout-action do-after 2 timeout-action ] callback 'thanks ] [ callback none ] ] foreach url bootstrap-urls [ send-message/async url compose/only [please test reachability (port-list)] func [result] [] ] do-after 10 timeout-action: [ ;print "Gotcha timeout action" reachable: unique reachable foreach port-id reachable [ insert tail publist join ahttp:// [public-ip ":" port-id] ] remove find handlers :h callback publist privlist ] ] find-relay-node: closure [bootstrap-node callback] [ remote-find-successor bootstrap-node random-key func [result] [ either object? result [ either result/relay [ ; find another node ; we don't want to use result/relay, because that way ; nodes that are relaying for a lot of node get higher ; probability to be chosen to relay for new nodes, ; which makes them relying for more and more nodes. ; in the end almost all nodes would be relayed by the same ; node... do-after 0 [find-relay-node bootstrap-node :callback] ] [ callback result ] ] [ callback none ] ] ] frn-callback: closure [relay] [ ;print ["frn-callback" mold :relay] if not object? relay [ print "Unable to find a new relay node [1]. :(" if relay: random/only successor-list [find-relay-node relay :frn-callback] ;halt exit ] node-send-message relay 1 [please relay] func [result /local my-id] [ either all [block? result parse result ['your 'relay 'id set my-id integer! end]] [ myself: make-node my-id myself/name myself/public-ip myself/public-urls myself/private-urls relay print ["Found new relay:" relay/name] node-send-message/keep relay 1 reduce ['relay my-id none] :relay-callback ; using key + 1 here to avoid a problem happening when you leave ; and try to join again soon after remote-find-successor relay make-finger-key myself/key 0 func [result] [ either object? result [ print ["My new successor is:" result/name] my-predecessor: none my-successor: result successor-list: make block! 16 finger: array 159 ] [ print "Unable to find a new successor... :(" ] ] ] [ print "Unable to find a new relay node [2]. :(" if relay: random/only successor-list [find-relay-node relay :frn-callback] ] ] ] relay-callback: func [message] [ if all [none? :message myself/relay-obj/failures < 5] [ node-send-message/keep myself/relay-obj 1 reduce ['relay myself/node-id none] :relay-callback exit ] if all [block? :message parse message ['ERROR 'NO-RELAY string!]] [ print "My relay is refusing me... :(" find-relay-node my-successor :frn-callback exit ] handle-message none :message func [result] [ node-send-message/keep myself/relay-obj 1 reduce ['relay myself/node-id :result] :relay-callback ] ] chord-join: closure [my-name bootstrap-urls callback] [ my-predecessor: none random/seed now find-my-ips random bootstrap-urls closure [public-ip private-ip] [ ;print ["my ips:" public-ip private-ip] if none? public-ip [ ; there was a problem callback false exit ] either public-ip = private-ip [ print "You are NOT under NAT" ] [ print "You are under NAT" ] ; UDP doesn't work right now, so we won't do NAT type discovery and UDP NAT traversal. find-reachable-ports random bootstrap-urls public-ip private-ip [80 2222 2223 3333] closure [public-urls private-urls /local node] [ ;print ["reachable urls:" mold public-urls] ;print ["private urls:" mold private-urls] node: make-node 0 "FAKE NODE" none random bootstrap-urls random bootstrap-urls none either empty? public-urls [ ; we need a relay print "Relay needed!" find-relay-node node closure [node] [ ;print ["find-relay-node result:" mold :node] if not object? node [callback false exit] print ["Found relay node:" node/name] ; this is to allow contacting a relay node which is in ; the LAN and under the same NAT proxy myself: make-node 0 my-name public-ip public-urls private-urls none node-send-message node 1 [please relay] func [result /local my-id] [ either all [block? result parse result ['your 'relay 'id set my-id integer! end]] [ myself: make-node my-id my-name public-ip public-urls private-urls node node-send-message/keep node 1 reduce ['relay my-id none] :relay-callback ; using key + 1 here to avoid a problem happening when you leave ; and try to join again soon after remote-find-successor node make-finger-key myself/key 0 func [result] [ either object? result [ print ["My successor is:" result/name] my-successor: result successor-list: make block! 16 callback true do-every 11 [stabilize check-predecessor true] ;do-every 7 [fix-fingers true] ] [ callback false ] ] ] [ callback false exit ] ] ] ] [ myself: make-node 0 my-name public-ip public-urls private-urls none remote-find-successor node make-finger-key myself/key 0 func [result] [ either object? result [ print ["My successor is:" result/name] my-successor: result successor-list: make block! 16 callback true do-every 11 [stabilize check-predecessor true] ;do-every 7 [fix-fingers true] ] [ callback false ] ] ] ] ] ] stabilize: does [ ;debug true "stabilize" if my-successor/key = myself/key [ either my-predecessor [ my-successor: my-predecessor ] [ exit ] ] node-send-message my-successor 1 [get predecessor] func [x] [ ;debug true ["stabilize:" my-successor/name "answered:" mold :x] if all [none? x my-successor/failures > 3] [ ; my successor failed - switch to new one. either empty? successor-list [ print "My successor failed, and my successor list is empty! :(" either all [my-predecessor my-predecessor/failures < 3] [ my-successor: my-predecessor ] [ my-successor: myself exit ] ] [ print ["Successor failure, switching to:" successor-list/1/name] my-successor: first successor-list remove successor-list ] ] if all [ block? x parse x node-rule x: block-to-node x in-interval? [except myself/key .. except my-successor/key] x/key ] [ print ["New successor:" x/name] my-successor: x ] ] node-send-message my-successor 1 compose/only [notify (node-to-block myself)] func [res] [] node-send-message my-successor 1 [get successor-list] func [result] [ if block? result [ while [not tail? result] [ either all [block? result/1 parse result/1 node-rule] [ result/1: block-to-node result/1 result: next result ] [ remove result ] ] successor-list: copy/part head result SUCCESSOR-LIST-MAXLENGTH ;prin "Successor list:" ;foreach succ successor-list [prin rejoin [succ/name ", "]] ;print "." ] ] ] notify: closure [node] [ ;debug true ["notify" node/name] if all [ node/key <> myself/key any [none? my-predecessor in-interval? [except my-predecessor/key .. except myself/key] node/key] ] [ node-send-message node 1 [ping] func [result] [ if result = 'pong [ print ["New predecessor:" node/name] my-predecessor: node if my-successor/key = myself/key [stabilize] ] ] ] ] make-finger-key: func [mykey n /local byte bit r] [ mykey: copy mykey bit: n // 8 byte: n - bit / 8 byte: 20 - byte n: pick [1 2 4 8 16 32 64 128] bit + 1 for i byte 1 -1 [ n: n + mykey/:i poke mykey i to char! r: n // 256 n: n - r / 256 if n = 0 [break] ] mykey ] fix-fingers: has [result] [ ;debug true "fix-fingers" if all [object? finger/1 finger/1/failures > 5] [finger/1: none] find-successor make-finger-key myself/key 160 - index? finger func [result] compose/only [if result [change/only (finger) result]] finger: next finger if tail? finger [finger: head finger] ] check-predecessor: does [ if all [my-predecessor my-predecessor/key = myself/key] [my-predecessor: none] ;debug true "check-predecessor" if my-predecessor [ node-send-message my-predecessor 1 [ping] func [result] [ if result <> 'pong [my-predecessor: none] ] ] ] ; handler for incoming messages insert tail handlers closure [port message callback /local result val1 val2 remote-ip] [ ;debug true ["Chord Handler:" mold message] if not all [object? myself object? my-successor] [callback none exit] if port? port [remote-ip: port/remote-ip] if not all [ block? message parse message [ 'find-successor set val1 binary! ( ;print "FIND-SUCCESSOR REQUEST!" find-successor val1 func [successor] [ ;debug true ["!> find-successor result:" mold successor] either successor [ callback node-to-block successor ] [ callback [Unable to find successor!] ] ] ) | 'notify set val1 into node-rule (notify block-to-node val1 callback 'ok) | 'get [ 'predecessor (callback either my-predecessor [node-to-block my-predecessor] ['unknown]) | 'relay (callback either myself/relay [myself/relay] [[I'm not using a relay!]]) | 'successor-list ( result: make block! 3 + length? successor-list insert/only result node-to-block my-successor foreach node successor-list [ insert/only tail result node-to-block node ] callback result ) ] | 'ping (callback 'pong) | 'what 'is 'my 'ip? (callback compose [your ip is (remote-ip)]) | 'please 'test 'reachability set val1 into [some integer!] ( foreach port-id val1 [ send-message/async join ahttp:// [remote-ip ":" port-id] [gotcha] func [res] [] ] callback 'done ) ] ] [ callback none ] ]