net2o-dht.fs 16.5 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
\ distributed hash table                             16oct2013py

\ Copyright (C) 2013   Bernd Paysan

\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

bernd's avatar
bernd committed
18
\ specify strength (in bytes), not length! length is 2*strength
bernd's avatar
bernd committed
19 20
32 Constant hash#128 \ 128 bit hash strength is enough!
64 Constant hash#256 \ 256 bit hash strength is more than enough!
bernd's avatar
bernd committed
21 22
keccak#max buffer: keyed-hash-buf
hash#256   buffer: keyed-hash-out
bernd's avatar
bernd committed
23

bernd's avatar
bernd committed
24
\ Idea: set "r" first half to the value, "r" second half to the key, diffuse
bernd's avatar
bernd committed
25 26 27 28
\ we use explicitely Keccak here, this needs to be globally the same!
\ Keyed hashs are there for unique handles

: >keyed-hash ( valaddr uval keyaddr ukey -- )
bernd's avatar
bernd committed
29
    \G generate a keyed hash: keyaddr ukey is the key for hasing valaddr uval
30
    hash( ." hashing: " 2over 85type ':' emit 2dup 85type F cr )
bernd's avatar
bernd committed
31
    c:hash c:hash
32
    hash( @keccak 200 85type F cr F cr ) ;
bernd's avatar
bernd committed
33 34

: keyed-hash#128 ( valaddr uval keyaddr ukey -- hashaddr uhash )
bernd's avatar
bernd committed
35
    c:0key >keyed-hash  keyed-hash-out hash#128 2dup keccak> ;
bernd's avatar
bernd committed
36
: keyed-hash#256 ( valaddr uval keyaddr ukey -- hashaddr uhash )
bernd's avatar
bernd committed
37
    c:0key >keyed-hash  keyed-hash-out hash#256 2dup keccak> ;
bernd's avatar
bernd committed
38 39

\ For speed reasons, the DHT is in-memory
bernd's avatar
bernd committed
40 41 42
\ we may keep a log of changes on disk if we want persistence
\ might not be saved too frequently... robustness comes from distribution
\ This is actually a PHT, a prefix hash tree; base 256 (bytes)
bernd's avatar
bernd committed
43

bernd's avatar
bernd committed
44
$200 cells Constant dht-size# \ $100 entris + $100 chains
bernd's avatar
bernd committed
45

bernd's avatar
bernd committed
46
Variable d#public
bernd's avatar
bernd committed
47 48 49 50 51 52

: dht@ ( bucket -- addr )  >r
    r@ @ 0= IF  dht-size# allocate throw dup r> ! dup dht-size# erase
    ELSE  r> @  THEN ;

\ keys are enumerated small integers
bernd's avatar
bernd committed
53 54 55 56

: enum ( n -- n+1 )  dup Constant 1+ ;

0
bernd's avatar
bernd committed
57
enum k#hash     \ hash itself is item 0
bernd's avatar
bernd committed
58 59
enum k#peers    \ distribution list - includes "where did I get this from"
                \ managed by the hash owner himself
bernd's avatar
bernd committed
60
enum k#owner    \ owner(s) of the object (pubkey+signature)
bernd's avatar
bernd committed
61 62
enum k#host     \ network id+routing from there (+signature)
enum k#map      \ peers have those parts of the object
63
enum k#tags     \ tags added
bernd's avatar
bernd committed
64
\ most stuff is added as tag or tag:value pair
bernd's avatar
bernd committed
65 66
cells Constant k#size

bernd's avatar
bernd committed
67
cmd-class class
bernd's avatar
bernd committed
68 69 70 71 72 73 74 75 76 77
    field: dht-hash
    field: dht-peers
    field: dht-owner
    field: dht-host
    field: dht-map
    field: dht-tags
end-class dht-class

Variable dht-table

bernd's avatar
bernd committed
78 79 80 81
\ map primitives
\ map layout: offset, bitmap pairs (64 bits each)
\ string array: starts with base map (32kB per bit)

bernd's avatar
bernd committed
82 83 84 85 86 87 88 89 90 91
\ !!TBD!!

\ hash errors

s" invalid DHT key"              throwcode !!no-dht-key!!
s" DHT permission denied"        throwcode !!dht-permission!!
s" no signature"                 throwcode !!no-sig!!
s" invalid signature"            throwcode !!wrong-sig!!

\ Hash state variables
bernd's avatar
bernd committed
92

93 94 95
$41 Constant sigonlysize#
$51 Constant sigsize#
$71 Constant sigpksize#
96
$10 Constant datesize#
bernd's avatar
bernd committed
97

bernd's avatar
bernd committed
98 99 100 101 102 103 104
\ signature printing

User sigdate datesize# cell- uallot drop \ date+expire date

: now>never ( -- )  ticks sigdate 64! 64#-1 sigdate 64'+ 64! ;
: forever ( -- )  64#0 sigdate 64! 64#-1 sigdate 64'+ 64! ;
: now+delta ( delta64 -- )  ticks 64dup sigdate 64! 64+ sigdate 64'+ 64! ;
bernd's avatar
bernd committed
105

bernd's avatar
bernd committed
106 107 108
: startdate@ ( addr u -- date ) + sigsize# - 64@ ;
: enddate@ ( addr u -- date ) + sigsize# - 64'+ 64@ ;

bernd's avatar
bernd committed
109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
: gen>host ( addr u -- addr u )
    2dup c:0key "host" >keyed-hash
    sigdate datesize# "date" >keyed-hash ;

: .check ( flag -- ) '' '' rot select xemit ;
: .sigdate ( tick -- )
    64dup 64#0  64= IF  ." forever"  64drop  EXIT  THEN
    64dup 64#-1 64= IF  ." never"  64drop  EXIT  THEN
    ticks 64over 64- 64dup #60.000.000.000 d>64 64u< IF
	64>f -1e-9 f* 10 6 0 f.rdp 's' emit 64drop
    ELSE  64drop .ticks  THEN ;
: .sigdates ( addr u -- )
    space 2dup startdate@ .sigdate ." ->" enddate@ .sigdate ;

\ checks for signatures

bernd's avatar
bernd committed
125 126
#10.000.000.000 d>64 64Constant fuzzedtime# \ allow clients to be 10s off

bernd's avatar
bernd committed
127
: >delete ( addr u type u2 -- addr u )
128
    "delete" >keyed-hash ;
129
: >host ( addr u -- addr u )  dup sigsize# u< !!no-sig!!
bernd's avatar
bernd committed
130
    c:0key 2dup sigsize# - "host" >keyed-hash
131
    2dup + sigsize# - datesize# "date" >keyed-hash ; \ hash from address
bernd's avatar
bernd committed
132

bernd's avatar
bernd committed
133
: check-date ( addr u -- addr u flag )
134
    2dup + 1- c@ keysize = &&
bernd's avatar
bernd committed
135
    2dup + sigsize# - >r
bernd's avatar
bernd committed
136
    ticks fuzzedtime# 64+ r@ 64@ r> 64'+ 64@
bernd's avatar
bernd committed
137 138
    64dup 64#-1 64<> IF  fuzzedtime# 64-2* 64+  THEN
    64within ;
139
: check-ed25519 ( addr u -- addr u flag )  2dup + 1- c@ $20 = ;
bernd's avatar
bernd committed
140
: verify-sig ( addr u pk -- )  >r
141 142
    check-date IF
	check-ed25519 IF
bernd's avatar
bernd committed
143
	    2dup + sigonlysize# - r> ed-verify
144 145
	    EXIT  THEN
    THEN  rdrop false ;
bernd's avatar
bernd committed
146
: verify-host ( addr u -- addr u flag )
bernd's avatar
bernd committed
147
    dht-hash $@ drop verify-sig ;
bernd's avatar
bernd committed
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166

\ revokation

4 datesize# + keysize 9 * + Constant revsize#

Variable revtoken

: 0oldkey ( -- ) \ pubkeys can stay
    oldskc keysize erase  oldskrev keysize erase ;

: keymove ( addr1 addr2 -- )  keysize move ;

: revoke-verify ( addr u1 pk string u2 -- addr u flag ) rot >r 2>r c:0key
    sigonlysize# - 2dup 2r> >keyed-hash
    sigdate datesize# "date" >keyed-hash
    2dup + r> ed-verify ;

: >revoke ( skrev -- )  skrev keymove  check-rev? 0= !!not-my-revsk!! ;

bernd's avatar
bernd committed
167 168
: +revsign ( sk pk -- )  ed-sign revtoken $+! bl revtoken c$+! ;

bernd's avatar
bernd committed
169 170
: sign-token, ( sk pk string u2 -- )
    c:0key revtoken $@ 2swap >keyed-hash
bernd's avatar
bernd committed
171
    sigdate datesize# "date" >keyed-hash +revsign ;
bernd's avatar
bernd committed
172 173 174 175 176 177 178 179 180 181 182

: revoke-key ( -- addr u )
    skc oldskc keymove  pkc oldpkc keymove  skrev oldskrev keymove
                                           \ backup keys
    oldskrev oldpkrev sk>pk                \ generate revokation pubkey
    gen-keys                               \ generate new keys
    pkc keysize 2* revtoken $!             \ my new key
    oldpkrev keysize revtoken $+!          \ revoke token
    oldskrev oldpkrev "revoke" sign-token, \ revoke signature
    skc pkc "selfsign" sign-token,         \ self signed with new key
    "!" revtoken 0 $ins                    \ "!" + oldkeylen+newkeylen to flag revokation
bernd's avatar
bernd committed
183 184 185 186
    revtoken $@ gen>host 2drop             \ sign host information with old key
    sigdate datesize# revtoken $+!
    oldskc oldpkc +revsign
    0oldkey revtoken $@ ;
bernd's avatar
bernd committed
187 188 189 190 191 192 193 194 195

: revoke? ( addr u -- addr u flag )
    2dup 1 umin "!" str= over revsize# = and &&    \ verify size and prefix
    >host verify-host &&                           \ verify it's a proper host
    2dup + sigsize# - sigdate datesize# move       \ copy signing date
    2dup 1 /string sigsize# -                      \ extract actual revoke part
    over "selfsign" revoke-verify &&'              \ verify self signature
    over keysize 2* + "revoke" revoke-verify &&'   \ verify revoke signature
    over keysize 2* + pkrev keymove
bernd's avatar
bernd committed
196 197
    pkrev dup sk-mask  dht-hash $@ drop keysize +  keypad ed-dh
    dht-hash $@ drop keysize str= nip nip ;       \ verify revoke token
bernd's avatar
bernd committed
198 199

: .revoke ( addr u -- )
200
    ." new key: " 2dup 1 /string 2dup + 1- c@ 2* umin 85type space
bernd's avatar
bernd committed
201 202 203 204
    revoke? -rot .sigdates .check ;

\ higher level checks

205
: check-host ( addr u -- addr u )
bernd's avatar
bernd committed
206 207
    over c@ '!' = IF  revoke?  ELSE  >host verify-host  THEN
    0= !!wrong-sig!! ;
bernd's avatar
bernd committed
208
: >tag ( addr u -- addr u )
209
    dup sigpksize# u< !!no-sig!!
bernd's avatar
bernd committed
210
    c:0key dht-hash $@ "tag" >keyed-hash
211 212
    2dup + sigsize# - datesize# "date" >keyed-hash
    2dup sigpksize# - ':' $split 2swap >keyed-hash ;
bernd's avatar
bernd committed
213
: verify-tag ( addr u -- addr u flag )
bernd's avatar
bernd committed
214
    2dup + sigpksize# - verify-sig ;
215
: check-tag ( addr u -- addr u )
bernd's avatar
bernd committed
216
    >tag verify-tag 0= !!wrong-sig!! ;
217
: delete-tag? ( addr u -- addr u flag )
bernd's avatar
bernd committed
218
    >tag "tag" >delete verify-tag ;
219
: delete-host? ( addr u -- addr u flag )
bernd's avatar
bernd committed
220
    >host "host" >delete verify-host ;
bernd's avatar
bernd committed
221 222 223

\ some hash storage primitives

bernd's avatar
bernd committed
224 225
: d#? ( addrkey u bucket -- addr u bucket/0 )
    dup @ 0= ?EXIT
bernd's avatar
bernd committed
226
    >r 2dup r@ @ .dht-hash $@ str= IF  r> EXIT  THEN
bernd's avatar
bernd committed
227 228 229
    rdrop false ;

: d# ( addr u hash -- bucket ) { hash }
bernd's avatar
bernd committed
230
    2dup bounds ?DO
bernd's avatar
bernd committed
231
	I c@ cells hash dht@ + d#? ?dup-IF
bernd's avatar
bernd committed
232
	    nip nip UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
233 234 235
	I c@ $100 + cells hash dht@ + to hash
    LOOP  true abort" dht exhausted - this should not happen" ;

236 237
: $ins[]sig ( addr u $array -- )
    \G insert O(log(n)) into pre-sorted array
bernd's avatar
bernd committed
238
    { $arr } 0 $arr $[]#
239
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
bernd's avatar
bernd committed
240
	    2dup sigsize# - $# $arr $[]@ sigsize# - compare dup 0= IF
bernd's avatar
bernd committed
241 242
		drop
		2dup startdate@
bernd's avatar
bernd committed
243
		$# $arr $[]@ startdate@ 64u>=
244 245
		IF   $# $arr $[]!
		ELSE  2drop  THEN EXIT  THEN
246 247
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
248
    0 { w^ ins$0 } ins$0 cell $arr r@ cells $ins r> $arr $[]! ;
bernd's avatar
bernd committed
249
: $del[]sig ( addr u $arrrray -- )
250
    \G delete O(log(n)) from pre-sorted array, check sigs
bernd's avatar
bernd committed
251
    { $arr } 0 $arr $[]#
252
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
253 254
	    2dup sigonlysize# - $# $arr $[]@ sigonlysize# -
	    compare dup 0= IF
bernd's avatar
bernd committed
255 256
		$# $arr $[] $off
		$arr $# cells cell $del
257 258 259
		2drop EXIT  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT 2drop 2drop ; \ not found
bernd's avatar
bernd committed
260

261
: >d#id ( addr u -- o )
bernd's avatar
bernd committed
262 263 264 265
    2dup d#public d#
    dup @ 0= IF  dht-class new >o
	o swap !  dht-hash $!  dht-table @ token-table !  o o>
    ELSE  @ nip nip  THEN ;
bernd's avatar
bernd committed
266 267
: .tag ( addr u -- ) 2dup 2>r 
    >tag verify-tag >r sigpksize# - type r> 2r> .sigdates .check ;
bernd's avatar
bernd committed
268
: .host ( addr u -- ) over c@ '!' = IF  .revoke  EXIT  THEN  2dup 2>r
bernd's avatar
bernd committed
269
    >host 2dup + sigonlysize# - dht-hash $@ drop ed-verify >r sigsize# - .ipaddr
bernd's avatar
bernd committed
270
    r> 2r> .sigdates .check ;
271
: host>$ ( addr u -- addr u' flag )
bernd's avatar
bernd committed
272
    >host 2dup + sigonlysize# - dht-hash $@ drop ed-verify >r sigsize# -
273
    r> ;
bernd's avatar
bernd committed
274
: d#. ( -- )
bernd's avatar
bernd committed
275
    dht-hash $@ 85type ." :" cr
bernd's avatar
bernd committed
276 277
    k#size cell DO
	I cell/ 0 .r ." : "
bernd's avatar
bernd committed
278
	dht-hash I +  I k#host cells = IF
bernd's avatar
bernd committed
279 280 281 282
	    [: cr .host ." ," ;]
	ELSE
	    [: cr .tag ." , " ;]
	THEN $[]map cr
bernd's avatar
bernd committed
283
    cell +LOOP ;
284 285 286 287 288 289 290 291 292

: d#host+ ( addr u -- ) \ with sanity checks
    check-host dht-host $ins[]sig dht( d#. ) ;
: d#tags+ ( addr u -- ) \ with sanity checks
    check-tag dht-tags $ins[]sig dht( d#. ) ;
: d#host- ( addr u -- ) \ with sanity checks
    delete-host? IF  dht-host $del[]sig dht( d#. )  ELSE  2drop  THEN ;
: d#tags- ( addr u -- ) \ with sanity checks
    delete-tag?  IF  dht-tags $del[]sig dht( d#. )  ELSE  2drop  THEN ;
bernd's avatar
bernd committed
293 294 295

\ commands for DHT

bernd's avatar
bernd committed
296 297
get-current also net2o-base definitions

298 299
$33 net2o: dht-id ( $:string -- o:o )
    $> >d#id dht( ." set dht to: " dup hex. F cr ) n:>o ;
bernd's avatar
bernd committed
300
\g set dht id for further operations on it
bernd's avatar
bernd committed
301 302
dht-table >table

303
reply-table $@ inherit-table dht-table
bernd's avatar
bernd committed
304

305
:noname dht-hash $@ $, dht-id ; dht-class to start-req
bernd's avatar
bernd committed
306
net2o' emit net2o: dht-host+ ( $:string -- ) $> d#host+ ;
307
+net2o: dht-host- ( $:string -- ) $> d#host- ;
308
+net2o: dht-tags+ ( $:string -- ) $> d#tags+ ;
309
+net2o: dht-tags- ( $:string -- ) $> d#tags- ;
bernd's avatar
bernd committed
310

bernd's avatar
bernd committed
311
set-current
bernd's avatar
bernd committed
312

bernd's avatar
bernd committed
313
\ queries
bernd's avatar
bernd committed
314

315 316 317 318
: d#host? ( -- )  dht-host
    [: dup $A0 + maxstring < IF  $, dht-host+  ELSE  2drop  THEN ;] $[]map ;
: d#tags? ( -- )  dht-tags
    [: dup $A0 + maxstring < IF  $, dht-tags+  ELSE  2drop  THEN ;] $[]map ;
bernd's avatar
bernd committed
319 320 321

fs-class class
    field: dht-queries
bernd's avatar
bernd committed
322
end-class dht-file-class
bernd's avatar
bernd committed
323

bernd's avatar
bernd committed
324
: d#c, ( addr u c -- addr' u' ) -rot xc!+? drop ; 
bernd's avatar
bernd committed
325
: d#$, ( addr1 u1 addr2 u2 -- addr' u' )
bernd's avatar
bernd committed
326
    2swap 2 pick d#c, 2swap
bernd's avatar
bernd committed
327 328
    2over rot umin dup >r move r> /string ;
: d#id, ( addr u -- addr' u' )
bernd's avatar
bernd committed
329
    0 d#c, dht-hash $@ d#$, ;
bernd's avatar
bernd committed
330 331 332
: d#values, ( addr u mask -- addr' u' ) { mask }
    k#size cell/ 1 DO
	mask 1 and IF
333
	    I dup cells dht-hash dht( ." access dht: " dup hex. over . F cr ) +
bernd's avatar
bernd committed
334
	    [: { k# a# u# } k# d#c, a# u# d#$, k# ;] $[]map drop
bernd's avatar
bernd committed
335 336 337
	THEN  mask 2/ to mask
    LOOP ;

bernd's avatar
bernd committed
338
:noname $FFFFFFFF n>64 64dup fs-limit 64! fs-size 64! ; dht-file-class to fs-open
bernd's avatar
bernd committed
339 340
:noname ( addr u -- n )  dup >r
    dht-queries $@ bounds ?DO
341 342
	I 1+ I c@ 2dup >d#id >o + c@ >r
	d#id, r> d#values, o>
bernd's avatar
bernd committed
343
    I c@ 2 + +LOOP  nip r> swap - ; dht-file-class to fs-read
bernd's avatar
bernd committed
344 345

: new>dht ( -- )
346
    [: dht-file-class new { w^ fs-ins } fs-ins cell file-state $+! drop ;]
bernd's avatar
bernd committed
347 348
    filestate-lock c-section ;

bernd's avatar
bernd committed
349
: d#open ( fid -- )  new>dht lastfile@ .fs-open ;
bernd's avatar
bernd committed
350 351
: d#query ( addr u mask fid -- )  state-addr >o
    >r dup dht-queries c$+! dht-queries $+! r> dht-queries c$+! o> ;
bernd's avatar
bernd committed
352

bernd's avatar
bernd committed
353
get-current definitions
bernd's avatar
bernd committed
354

355 356
+net2o: dht-host? ( -- ) d#host? ;
+net2o: dht-tags? ( -- ) d#tags? ;
357 358
\ +net2o: dht-open ( fid -- ) 64>n d#open ;
\ +net2o: dht-query ( addr u mask fid -- ) 2*64>n d#query ;
bernd's avatar
bernd committed
359

bernd's avatar
bernd committed
360 361
previous set-current

bernd's avatar
bernd committed
362 363
\ value reading requires constructing answer packet

bernd's avatar
bernd committed
364
gen-table $freeze
bernd's avatar
bernd committed
365 366 367
' context-table is gen-table

\ facility stuff
bernd's avatar
bernd committed
368

369
: .sig ( -- )  sigdate datesize# type skc pkc ed-sign type space ;
bernd's avatar
bernd committed
370 371
: .pk ( -- )  pkc keysize type ;
: host$ ( addr u -- hostaddr host-u ) [: type .sig ;] $tmp ;
bernd's avatar
bernd committed
372 373 374 375
: gen-host ( addr u -- addr' u' )
    gen>host host$ ;
: gen-host-del ( addr u -- addr' u' )
    gen>host "host" >delete host$ ;
bernd's avatar
bernd committed
376

bernd's avatar
bernd committed
377
: gen>tag ( addr u hash-addr uh -- addr u )
bernd's avatar
bernd committed
378
    c:0key "tag" >keyed-hash
379
    sigdate datesize# "date" >keyed-hash
bernd's avatar
bernd committed
380
    2dup ':' $split 2swap >keyed-hash ;
381
: tag$ ( addr u -- tagaddr tag-u ) [: type .pk .sig ;] $tmp ;
bernd's avatar
bernd committed
382

bernd's avatar
bernd committed
383 384 385 386 387
: gen-tag ( addr u hash-addr uh -- addr' u' )
    gen>tag tag$ ;
: gen-tag-del ( addr u hash-addr uh -- addr' u' )
    gen>tag "tag" >delete tag$ ;

bernd's avatar
bernd committed
388 389
\ addme stuff

bernd's avatar
bernd committed
390
also net2o-base
bernd's avatar
bernd committed
391

bernd's avatar
bernd committed
392 393
: pub? ( addr u -- addr u flag )  skip-symname
    over c@ '2' = IF  dup $17 u<=  ELSE  false  THEN ;
bernd's avatar
bernd committed
394 395 396

false Value add-myip

bernd's avatar
bernd committed
397
: addme-end ( -- )
bernd's avatar
bernd committed
398
    add-myip IF
399
	my-ip$ [: gen-host $, dht-host+ ;] $[]map
bernd's avatar
bernd committed
400
    THEN
bernd's avatar
bernd committed
401
    endwith request,  end-cmd
bernd's avatar
bernd committed
402
    ['] end-cmd IS expect-reply? ;
bernd's avatar
bernd committed
403
: addme ( addr u -- ) 2dup .iperr
bernd's avatar
bernd committed
404
    pub? IF
bernd's avatar
bernd committed
405
	my-ip-merge IF  2drop  EXIT  THEN
bernd's avatar
bernd committed
406
	my-ip$ $ins[]  EXIT  THEN
bernd's avatar
bernd committed
407
\    2dup my-ip? 0= IF  2dup my-ip$ $ins[]  THEN
bernd's avatar
bernd committed
408
    now>never
bernd's avatar
bernd committed
409
    what's expect-reply? ['] addme-end <> IF
bernd's avatar
bernd committed
410
	expect-reply pkc keysize 2* $, dht-id
bernd's avatar
bernd committed
411
    THEN
412
    gen-host $, dht-host+
bernd's avatar
bernd committed
413
    ['] addme-end IS expect-reply? ;
bernd's avatar
bernd committed
414 415 416
previous

: +addme ['] addme setip-xt ! ;
417 418
: -setip ['] .iperr setip-xt ! ;

bernd's avatar
bernd committed
419 420 421
\ replace me stuff

also net2o-base
422
: replace-me, ( -- )
423
    pkc keysize 2* $, dht-id dht-host? endwith ;
bernd's avatar
bernd committed
424 425

: remove-me, ( -- )
426
    dht-host dup >r
bernd's avatar
bernd committed
427
    [: sigsize# - 2dup + sigdate datesize# move
428
      gen-host-del $, dht-host- ;] $[]map
bernd's avatar
bernd committed
429
    r> $[]off ;
bernd's avatar
bernd committed
430 431
previous

bernd's avatar
bernd committed
432
: me>d#id ( -- ) pkc keysize 2* >d#id ;
bernd's avatar
bernd committed
433

bernd's avatar
bernd committed
434
: n2o:send-replace ( -- )
435
    me>d#id >o dht-host $[]# IF
436
	net2o-code   expect-reply
437 438 439 440
	  pkc keysize 2* $, dht-id remove-me, endwith
	  cookie+request
	end-code|
    THEN o> ;
bernd's avatar
bernd committed
441

bernd's avatar
bernd committed
442
: set-revocation ( addr u -- )
443
    dht-host $ins[]sig ;
bernd's avatar
bernd committed
444

445 446
Defer renew-key

bernd's avatar
bernd committed
447
: n2o:send-revoke ( addr u -- )
bernd's avatar
bernd committed
448 449
    keysize <> !!keysize!! >revoke
    me>d#id >o
bernd's avatar
bernd committed
450
    net2o-code  expect-reply
451
      dht-hash $@ $, dht-id remove-me,
bernd's avatar
bernd committed
452
      revoke-key 2dup set-revocation
453
      2dup $, dht-host+ endwith
bernd's avatar
bernd committed
454 455
      cookie+request
    end-code| \ send revocation upstrem
bernd's avatar
bernd committed
456
    dht-hash $@ renew-key drop o> ; \ replace key in key storage
bernd's avatar
bernd committed
457

bernd's avatar
bernd committed
458
: replace-me ( -- )  +addme
459
    net2o-code   expect-reply get-ip replace-me, cookie+request
bernd's avatar
bernd committed
460 461
    end-code| -setip
    n2o:send-replace ;
bernd's avatar
bernd committed
462 463 464 465

: revoke-me ( addr u -- )
    \G give it your revocation secret
    +addme
466
    net2o-code   expect-reply replace-me, cookie+request  end-code|
bernd's avatar
bernd committed
467
    -setip n2o:send-revoke ;
bernd's avatar
bernd committed
468

bernd's avatar
bernd committed
469
: do-disconnect ( -- )
470
    net2o-code log .time s" Disconnect" $, type cr endwith
bernd's avatar
bernd committed
471
      close-all disconnect  end-code msg( ." disconnected" F cr )
bernd's avatar
bernd committed
472 473
    n2o:dispose-context msg( ." Disposed context" F cr ) ;

474
: beacon-replace ( -- )  \ sign on, and do a replace-me
bernd's avatar
bernd committed
475 476 477 478
    sockaddr alen @ save-mem
    [: over >r insert-address r> free throw
      n2o:new-context $1000 $1000 n2o:connect msg( ." beacon: connected" F cr )
      replace-me msg( ." beacon: replaced" F cr )
bernd's avatar
bernd committed
479
      do-disconnect ;] 3 net2o-task drop ;
480 481 482 483 484 485

\ beacon handling

:noname ( char -- )
    case '?' of \ if we don't know that address, send a reply
	    replace-beacon( true )else( sockaddr alen @ 2dup routes #key -1 = ) IF
bernd's avatar
bernd committed
486
		beacon( ." Send reply to: " sockaddr alen @ .address F cr )
487 488 489 490
		net2o-sock fileno s" !" 0 sockaddr alen @ sendto +send
	    THEN
	endof
	'!' of \ I got a reply, my address is unknown
bernd's avatar
bernd committed
491
	    beacon( ." Got reply: " sockaddr alen @ .address F cr )
492 493 494 495 496 497 498 499
	    sockaddr alen @ false beacons [: rot >r 2over str= r> or ;] $[]map
	    IF
		beacon( ." Try replace" cr )
		beacon-replace
	    THEN
	    2drop
	endof
    endcase ; is handle-beacon
bernd's avatar
bernd committed
500

501 502 503 504 505 506 507 508 509 510 511 512
0 [IF]
Local Variables:
forth-local-words:
    (
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     ("[a-z0-9]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
    )
forth-local-indent-words:
    (
     (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate)
bernd's avatar
bernd committed
513 514
     (("[:" "net2o-code") (0 . 1) (0 . 1) immediate)
     ((";]" "end-code" "end-code|") (-1 . 0) (0 . -1) immediate)
515 516 517
    )
End:
[THEN]