net2o.fs 74.5 KB
Newer Older
bernd's avatar
bernd committed
1 2
\ net2o protocol stack

3
\ Copyright (C) 2010-2014   Bernd Paysan
bernd's avatar
bernd committed
4 5 6 7 8 9 10 11 12 13 14 15 16

\ 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 Paysan's avatar
Bernd Paysan committed
17

bernd's avatar
bernd committed
18 19
\ helper words

bernd's avatar
bernd committed
20
require net2o-err.fs
bernd's avatar
bernd committed
21

bernd's avatar
bernd committed
22 23
\ required tools

bernd's avatar
bernd committed
24
\ require smartdots.fs
bernd's avatar
bernd committed
25 26
require mini-oof2.fs
require user-object.fs
Bernd Paysan's avatar
Bernd Paysan committed
27
require unix/socket.fs
bernd's avatar
bernd committed
28
require unix/mmap.fs
bernd's avatar
bernd committed
29
require unix/pthread.fs
bernd's avatar
bernd committed
30
require unix/filestat.fs
31
require net2o-tools.fs
bernd's avatar
bernd committed
32
require 64bit.fs
bernd's avatar
bernd committed
33
require debugging.fs
bernd's avatar
bernd committed
34
require kregion.fs
bernd's avatar
bernd committed
35
require libkeccak.fs
bernd's avatar
bernd committed
36
\ require wurstkessel.fs
37 38
\ wurstkessel-o crypto-o !
require rng.fs
39
require ed25519-donna.fs
bernd's avatar
bernd committed
40
require hash-table.fs
41

bernd's avatar
bernd committed
42 43 44 45 46 47 48
\ user values

UValue inbuf    ( -- addr )
UValue outbuf   ( -- addr )
UValue cmd0buf  ( -- addr )
UValue init0buf ( -- addr )
UValue sockaddr ( -- addr )
bernd's avatar
bernd committed
49
UValue sockaddr1 ( -- addr ) \ temporary buffer
bernd's avatar
bernd committed
50 51 52
UValue aligned$
UValue statbuf

bernd's avatar
bernd committed
53 54
[IFDEF] 64bit
    ' min! Alias 64min!
bernd's avatar
bernd committed
55
    ' max! Alias 64max!
bernd's avatar
bernd committed
56 57
    ' umin! Alias 64umin!
    ' umax! Alias 64umax!
bernd's avatar
bernd committed
58
    ' !@ Alias 64!@
bernd's avatar
bernd committed
59
[ELSE]
60 61
    : dumin ( ud1 ud2 -- ud3 )  2over 2over du> IF  2swap  THEN  2drop ;
    : dumax ( ud1 ud2 -- ud3 )  2over 2over du< IF  2swap  THEN  2drop ;
bernd's avatar
bernd committed
62
    : 64!@ ( value addr -- old-value )   >r r@ 64@ 64swap r> 64! ;
bernd's avatar
bernd committed
63
    : 64min! ( d addr -- )  >r r@ 64@ dmin r> 64! ;
bernd's avatar
bernd committed
64
    : 64max! ( d addr -- )  >r r@ 64@ dmax r> 64! ;
bernd's avatar
bernd committed
65 66
    : 64umin! ( n addr -- )   >r r@ 64@ dumin r> 64! ;
    : 64umax! ( n addr -- )   >r r@ 64@ dumin r> 64! ;
bernd's avatar
bernd committed
67 68
[THEN]

69
\ bit vectors, lsb first
bernd's avatar
bernd committed
70

bernd's avatar
bernd committed
71
: bits ( n -- n ) 1 swap lshift ;
bernd's avatar
bernd committed
72 73 74

: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
: +bit ( addr n -- )  >bit over c@ or swap c! ;
75 76
: +bit@ ( addr n -- flag )  >bit over c@ 2dup and >r
    or swap c! r> 0<> ;
bernd's avatar
bernd committed
77
: -bit ( addr n -- )  >bit invert over c@ and swap c! ;
78 79
: -bit@ ( addr n -- flag )  >bit over c@ 2dup and >r
    invert or invert swap c! r> 0<> ;
bernd's avatar
bernd committed
80
: bit! ( flag addr n -- ) rot IF  +bit  ELSE  -bit  THEN ;
81
: bit@ ( addr n -- flag )  >bit swap c@ and 0<> ;
bernd's avatar
bernd committed
82

83 84
: bittype ( addr base n -- )  bounds +DO
	dup I bit@ '+' '-' rot select emit  LOOP  drop ;
bernd's avatar
bernd committed
85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101

: bit-erase ( addr off len -- )
    dup 8 u>= IF
	>r dup 7 and >r 3 rshift + r@ bits 1- over andc!
	1+ 8 r> - r> swap -
	dup 7 and >r 3 rshift 2dup erase +
	0 r> THEN
    bounds ?DO  dup I -bit  LOOP  drop ;

: bit-fill ( addr off len -- )
    dup 8 u>= IF
	>r dup 7 and >r 3 rshift + r@ bits 1- invert over orc!
	1+ 8 r> - r> swap -
	dup 7 and >r 3 rshift 2dup $FF fill +
	0 r> THEN
    bounds ?DO  dup I +bit  LOOP  drop ;

bernd's avatar
bernd committed
102 103
\ variable length integers

bernd's avatar
bernd committed
104
[IFDEF] 64bit
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
    : p@+ ( addr -- u64 addr' )  >r 0
	BEGIN  7 lshift r@ c@ $7F and or r@ c@ $80 and  WHILE
		r> 1+ >r  REPEAT  r> 1+ ;
    : p-size ( u64 -- n ) \ to speed up: binary tree comparison
	\ flag IF  1  ELSE  2  THEN  equals  flag 2 +
	dup    $FFFFFFFFFFFFFF u<= IF
	    dup       $FFFFFFF u<= IF
		dup      $3FFF u<= IF
		    $00000007F u<= 2 +  EXIT  THEN
		$00000001FFFFF u<= 4 +  EXIT  THEN
	    dup   $3FFFFFFFFFF u<= IF
		$00007FFFFFFFF u<= 6 +  EXIT  THEN
	    $00001FFFFFFFFFFFF u<= 8 +  EXIT  THEN
	$000007FFFFFFFFFFFFFFF u<= 10 + ;
    : p!+ ( u64 addr -- addr' )  over p-size + dup >r >r
	dup $7F and r> 1- dup >r c!  7 rshift
	BEGIN  dup  WHILE  dup $7F and $80 or r> 1- dup >r c! 7 rshift  REPEAT
	drop rdrop r> ;
[ELSE]
    : p@+ ( addr -- u64 addr' )  >r 0.
bernd's avatar
bernd committed
125
	BEGIN  7 64lshift r@ c@ $7F and 0 64or r@ c@ $80 and  WHILE
126 127 128 129 130 131 132 133 134 135 136 137 138
		r> 1+ >r  REPEAT  r> 1+ ;
    : p-size ( x64 -- n ) \ to speed up: binary tree comparison
	\ flag IF  1  ELSE  2  THEN  equals  flag 2 +
	2dup   $FFFFFFFFFFFFFF. du<= IF
	    2dup      $FFFFFFF. du<= IF
		2dup     $3FFF. du<= IF
		    $00000007F. du<= 2 +  EXIT  THEN
		$00000001FFFFF. du<= 4 +  EXIT  THEN
	    2dup  $3FFFFFFFFFF. du<= IF
		$00007FFFFFFFF. du<= 6 +  EXIT  THEN
	    $00001FFFFFFFFFFFF. du<= 8 +  EXIT  THEN
	$000007FFFFFFFFFFFFFFF. du<= 10 + ;
    : p!+ ( u64 addr -- addr' )  >r 2dup p-size r> + dup >r >r
bernd's avatar
bernd committed
139 140
	over $7F and r> 1- dup >r c!  7 64rshift
	BEGIN  2dup or  WHILE  over $7F and $80 or r> 1- dup >r c! 7 64rshift  REPEAT
141 142
	2drop rdrop r> ;
[THEN]
bernd's avatar
bernd committed
143

bernd's avatar
bernd committed
144 145
: w, ( w -- )  here w! 2 allot ;

bernd's avatar
bernd committed
146 147 148 149 150 151 152 153
\ bit reversing

: bitreverse8 ( u1 -- u2 )
    0 8 0 DO  2* over 1 and + swap 2/ swap  LOOP  nip ;

Create reverse-table $100 0 [DO] [I] bitreverse8 c, [LOOP]

: reverse8 ( c1 -- c2 ) reverse-table + c@ ;
bernd's avatar
bernd committed
154
: reverse ( x1 -- x2 )
bernd's avatar
bernd committed
155
    0 cell 0 DO  8 lshift over $FF and reverse8 or
bernd's avatar
bernd committed
156
       swap 8 rshift swap  LOOP  nip ;
bernd's avatar
bernd committed
157 158 159 160 161 162 163 164
: reverse$16 ( addrsrc addrdst -- ) { dst } dup >r
    count reverse8 r@ $F + c@ reverse8 dst     c! dst $F + c!
    count reverse8 r@ $E + c@ reverse8 dst 1+  c! dst $E + c!
    count reverse8 r@ $D + c@ reverse8 dst 2 + c! dst $D + c!
    count reverse8 r@ $C + c@ reverse8 dst 3 + c! dst $C + c!
    count reverse8 r@ $B + c@ reverse8 dst 4 + c! dst $B + c!
    count reverse8 r@ $A + c@ reverse8 dst 5 + c! dst $A + c!
    count reverse8 r@ $9 + c@ reverse8 dst 6 + c! dst $9 + c!
bernd's avatar
bernd committed
165
    c@    reverse8 r> $8 + c@ reverse8 dst 7 + c! dst $8 + c! ;
bernd's avatar
bernd committed
166 167

\ IP address stuff
bernd's avatar
bernd committed
168 169

0 Value net2o-sock
bernd's avatar
bernd committed
170
0 Value query-sock
bernd's avatar
bernd committed
171 172 173
Variable my-ip$

Create fake-ip4 $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $FFFF w,
bernd's avatar
bernd committed
174
\ prefix for IPv4 addresses encoded as IPv6
bernd's avatar
bernd committed
175

bernd's avatar
bernd committed
176 177 178 179 180 181
\ convention:
\ '!' is a key revocation, it contains the new key
\ '0' is a identifier, followed by an address (must be '1' or '2')
\ '1' indicates net2o
\ '2' IPv6+IPv4
\ Tags are kept sorted, so you'll get revocations first, then net2o and IPv6+4
bernd's avatar
bernd committed
182 183 184
\ Symbolic name may start with '@'+len followed by the name

Variable myhost
bernd's avatar
bernd committed
185
Variable myprio \ lower is more important, 0 is "no priority"
bernd's avatar
bernd committed
186

bernd's avatar
bernd committed
187
: default-host ( -- )
bernd's avatar
bernd committed
188
    pad $100 gethostname drop pad cstring>sstring myhost $!
bernd's avatar
bernd committed
189
    10 myprio ! ;
bernd's avatar
bernd committed
190

bernd's avatar
bernd committed
191 192 193 194 195
default-host

: .myname ( -- )
    myprio @ IF  '0' emit myprio @ emit  THEN
    myhost $@len IF  myhost $@ dup '@' + emit type  THEN ;
196

bernd's avatar
bernd committed
197
Create ip6::0 here 16 dup allot erase
bernd's avatar
bernd committed
198 199 200
: .ip6::0 ( -- )  ip6::0 $10 type ;
: .ip4::0 ( -- )  ip6::0 4 type ;

bernd's avatar
bernd committed
201 202 203
Create sockaddr" 2 c, $16 allot

: .sockaddr
bernd's avatar
bernd committed
204
    \ convert socket into net2o address token
bernd's avatar
bernd committed
205
    [: { addr alen -- sockaddr u } '2' emit
bernd's avatar
bernd committed
206 207
    case addr family w@
	AF_INET of
bernd's avatar
bernd committed
208
	    .ip6::0 addr sin_addr 4 move type
bernd's avatar
bernd committed
209 210 211
	endof
	AF_INET6 of
	    addr sin6_addr 12 fake-ip4 over str= IF
bernd's avatar
bernd committed
212
		.ip6::0 addr sin6_addr 12 + 4 type
bernd's avatar
bernd committed
213
	    ELSE
bernd's avatar
bernd committed
214 215
		addr sin6_addr $10 type .ip4::0
	    THEN
bernd's avatar
bernd committed
216
	endof
bernd's avatar
bernd committed
217 218
    endcase
    addr port 2 type ;] $tmp ;
bernd's avatar
bernd committed
219

220
: .port ( addr len -- addr' len' )
221 222
    ." :" over be-uw@ 0 ['] .r #10 base-execute  2 /string ;
: .net2o ( addr u -- ) dup IF  ." |" xtype  ELSE  2drop  THEN ;
bernd's avatar
bernd committed
223 224
: .ip4b ( addr len -- addr' len' )
    over c@ 0 ['] .r #10 base-execute 1 /string ;
bernd's avatar
bernd committed
225 226
: .ip4a ( addr len -- addr' len' )
    .ip4b ." ." .ip4b ." ." .ip4b ." ." .ip4b ;
bernd's avatar
bernd committed
227
: .ip4 ( addr len -- )
228
    .ip4a .port .net2o ;
bernd's avatar
bernd committed
229 230 231 232 233
User ip6:#
: .ip6w ( addr len -- addr' len' )
    over be-uw@ [: ?dup-IF 0 .r ip6:# off  ELSE  1 ip6:# +! THEN ;] $10 base-execute
    2 /string ;

bernd's avatar
bernd committed
234 235
: .ip6a ( addr len -- addr' len' )
    2dup fake-ip4 12 string-prefix? IF  12 /string .ip4a  EXIT  THEN
bernd's avatar
bernd committed
236 237
    -1 ip6:# !
    '[' 8 0 DO  ip6:# @ 2 < IF  emit  ELSE drop  THEN .ip6w ':'  LOOP
238
    drop ." ]" ;
bernd's avatar
bernd committed
239 240
: .ip6 ( addr len -- )
    .ip6a .port .net2o ;
bernd's avatar
bernd committed
241

bernd's avatar
bernd committed
242
: .ip64 ( addr len -- )
bernd's avatar
bernd committed
243 244 245
    over $10 ip6::0 over str= IF  16 /string  ELSE  .ip6a  THEN
    over   4 ip6::0 over str= IF  4 /string   ELSE  .ip4a  THEN
    .port .net2o ;
bernd's avatar
bernd committed
246 247

: .address ( addr u -- )
bernd's avatar
bernd committed
248 249 250
    over w@ AF_INET6 =
    IF  drop dup sin6_addr $10 .ip6a 2drop
    ELSE  drop dup sin_addr 4 .ip4a 2drop  THEN
251
    port 2 .port 2drop ; 
bernd's avatar
bernd committed
252 253 254

\ NAT traversal stuff: print IP addresses

bernd's avatar
bernd committed
255
: skip-symname ( addr u -- addr' u' )
bernd's avatar
bernd committed
256
    over c@ '0' = IF  2 safe/string  THEN
bernd's avatar
bernd committed
257 258
    over c@ '?' - 0 max safe/string ;
: .symname ( addr u -- addr' u' )
bernd's avatar
bernd committed
259
    over c@ '0' = IF  over 1+ c@ 0 .r '#' emit  2 safe/string  THEN
bernd's avatar
bernd committed
260 261 262 263
    over c@ '?' - 0 max >r r@ IF   '"' emit over r@ 1 /string type '"' emit  THEN
    r> safe/string ;

: .ipaddr ( addr len -- )  .symname
bernd's avatar
bernd committed
264
    case  over c@ >r 1 /string r>
bernd's avatar
bernd committed
265 266
	'1' of  ." |" xtype  endof
	'2' of  .ip64 endof
bernd's avatar
bernd committed
267
	dup emit -rot dump endcase ;
bernd's avatar
bernd committed
268

bernd's avatar
bernd committed
269
: .iperr ( addr len -- ) [: .time ." connected from: " .ipaddr cr ;] $err ;
bernd's avatar
bernd committed
270

bernd's avatar
bernd committed
271 272 273 274 275
: ipv4! ( ipv4 sockaddr -- ) >r
    r@ sin6_addr 12 + be-l!
    $FFFF r@ sin6_addr 8 + be-l!
    0     r@ sin6_addr 4 + l!
    0     r> sin6_addr l! ;
bernd's avatar
bernd committed
276

bernd's avatar
bernd committed
277 278 279 280 281
: sock-rest ( sockaddr -- addr u ) >r
    AF_INET6 r@ family w!
    0        r@ sin6_flowinfo l!
    0        r@ sin6_scope_id l!
    r> sockaddr_in6 %size ;
bernd's avatar
bernd committed
282

bernd's avatar
bernd committed
283 284
: my-port ( -- port )
    sockaddr_in6 %size alen !
285
    net2o-sock sockaddr1 alen getsockname ?ior
bernd's avatar
bernd committed
286
    sockaddr1 port be-uw@ ;
bernd's avatar
bernd committed
287

bernd's avatar
bernd committed
288 289 290 291 292
: sock[ ( -- )  query-sock ?EXIT
    new-udp-socket46 to query-sock ;
: ]sock ( -- )  query-sock 0= ?EXIT
    query-sock closesocket 0 to query-sock ?ior ;

bernd's avatar
bernd committed
293 294
: 'sock ( xt -- )  sock[ catch ]sock throw ;

bernd's avatar
bernd committed
295
: ?fake-ip4 ( -- addr u )
bernd's avatar
bernd committed
296
    sockaddr1 sin6_addr dup $C fake-ip4 over
bernd's avatar
bernd committed
297 298
    str= IF  12 + 4  ELSE  $10   THEN ;

bernd's avatar
bernd committed
299
: check-ip4 ( ip4addr -- my-ip4addr 4 ) noipv4( 0 EXIT )
bernd's avatar
bernd committed
300
    [:  sockaddr_in6 %size alen !
301
	sockaddr ipv4! query-sock sockaddr sock-rest connect
bernd's avatar
bernd committed
302 303 304 305 306 307
	dup 0< errno 101 = and  IF  drop ip6::0 4  EXIT  THEN  ?ior
	query-sock sockaddr1 alen getsockname
	dup 0< errno 101 = and  IF  drop ip6::0 4  EXIT  THEN  ?ior
	sockaddr1 family w@ AF_INET6 =
	IF  ?fake-ip4  ELSE  sin_addr 4  THEN
    ;] 'sock ;
bernd's avatar
bernd committed
308

bernd's avatar
bernd committed
309 310
$25DDC249 Constant dummy-ipv4 \ this is my net2o ipv4 address
Create dummy-ipv6 \ this is my net2o ipv6 address
311 312
$2A c, $03 c, $40 c, $00 c, $00 c, $02 c, $01 c, $88 c,
$0000 w, $0000 w, $0000 w, $00 c, $01 c,
bernd's avatar
bernd committed
313
Create local-ipv6
bernd's avatar
bernd committed
314
$FD c, $00 c, $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $0100 w,
bernd's avatar
bernd committed
315

bernd's avatar
bernd committed
316 317
0 Value my-port#

bernd's avatar
bernd committed
318
: check-ip6 ( dummy -- ip6addr u ) noipv6( 0 EXIT )
319
    \G return IPv6 address - if length is 0, not reachable with IPv6
bernd's avatar
bernd committed
320 321
    [:  sockaddr_in6 %size alen !
	sockaddr sin6_addr $10 move
bernd's avatar
bernd committed
322 323 324 325 326 327
	query-sock sockaddr sock-rest connect
	dup 0< errno 101 = and  IF  drop ip6::0 $10  EXIT  THEN  ?ior
	query-sock sockaddr1 alen getsockname
	dup 0< errno 101 = and  IF  drop ip6::0 $10  EXIT  THEN  ?ior
	?fake-ip4
    ;] 'sock ;
bernd's avatar
bernd committed
328

bernd's avatar
bernd committed
329
: check-ip64 ( dummy -- ipaddr u ) noipv4( check-ip6 EXIT )
bernd's avatar
bernd committed
330
    >r r@ check-ip6 dup IF  rdrop  EXIT  THEN
bernd's avatar
bernd committed
331
    2drop r> $10 + be-ul@ check-ip4 ;
bernd's avatar
bernd committed
332

333
: try-ip ( addr u -- flag )
bernd's avatar
bernd committed
334
    [: query-sock -rot connect 0= ;] 'sock ;
335

bernd's avatar
bernd committed
336
: global-ip4 ( -- ip4addr u )  dummy-ipv4 check-ip4 ;
bernd's avatar
bernd committed
337
: global-ip6 ( -- ip6addr u )  dummy-ipv6 check-ip6 ;
bernd's avatar
bernd committed
338
: local-ip6 ( -- ip6addr u )   local-ipv6 check-ip6 over c@ $FD = and ;
bernd's avatar
bernd committed
339

bernd's avatar
bernd committed
340 341
\ insert into sorted string array

bernd's avatar
bernd committed
342 343 344 345 346
: $ins[] ( addr u $array -- )
    \G insert O(log(n)) into pre-sorted array
    { $a } 0 $a $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup $# $a $[]@ compare dup 0= IF
347
		drop $# $a $[]!  EXIT  THEN
bernd's avatar
bernd committed
348 349
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
350
    0 { w^ ins$0 } ins$0 cell $a r@ cells $ins r> $a $[]! ;
bernd's avatar
bernd committed
351 352 353 354 355 356 357 358 359 360 361
: $del[] ( addr u $array -- )
    \G delete O(log(n)) from pre-sorted array
    { $a } 0 $a $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup $# $a $[]@ compare dup 0= IF
		drop $# $a $[] $off
		$a $# cells cell $del
		2drop EXIT  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT 2drop 2drop ; \ not found

bernd's avatar
bernd committed
362 363
\ add IP addresses

bernd's avatar
bernd committed
364 365
Variable myname

bernd's avatar
bernd committed
366
: +my-ip ( addr u -- ) dup 0= IF  2drop  EXIT  THEN
bernd's avatar
bernd committed
367 368
    [:  .myname '2' emit
	dup 4 = IF ip6::0 $10 type ELSE dup $10 = IF type ip6::0 4 THEN THEN type
369
	my-port# 8 rshift emit my-port# $FF and emit ;] $tmp
bernd's avatar
bernd committed
370
    my-ip$ $ins[] ;
bernd's avatar
bernd committed
371

bernd's avatar
bernd committed
372 373 374
Variable $tmp2

: !my-ips ( -- )  $tmp2 $off
bernd's avatar
bernd committed
375
    global-ip6 tuck [: type global-ip4 type ;] $tmp2 $exec
bernd's avatar
bernd committed
376
    $tmp2 $@ +my-ip
bernd's avatar
bernd committed
377 378
    0= IF  local-ip6  +my-ip THEN ;

bernd's avatar
bernd committed
379 380
\ this looks ok

bernd's avatar
bernd committed
381 382 383 384
: && ( flag -- ) ]] dup 0= ?EXIT drop [[ ; immediate compile-only
: &&' ( addr u addr' u' flag -- addr u false / addr u addr' u' )
    ]] 0= IF 2drop false EXIT THEN [[ ; immediate compile-only

385
: str=?0 ( addr1 u1 addr2 u2 -- flag )
bernd's avatar
bernd committed
386 387 388
    2dup ip6::0 over str= >r
    2over ip6::0 over str= >r str= r> r> or or ;

bernd's avatar
bernd committed
389
: my-ip= skip-symname 2swap skip-symname { addr1 u1 addr2 u2 -- flag }
bernd's avatar
bernd committed
390 391 392 393 394 395 396 397
    addr1 c@ '2' = addr2 c@ '2' = and &&
    addr1 u1 $15 safe/string addr2 u2 $15 safe/string str= &&
    addr1 1+ $10 addr2 1+ over str=?0 &&
    addr1 $11 + 4 addr2 $11 + over str=?0 ;

: str>merge ( addr1 u1 addr2 u2 -- )
    2dup ip6::0 over str= IF  rot umin move  ELSE  2drop 2drop  THEN ;

398 399
: my-ip>merge ( addr1 u1 addr2 u2 -- )
    skip-symname 2swap skip-symname 2swap
bernd's avatar
bernd committed
400 401 402 403 404 405 406 407
    { addr1 u1 addr2 u2 -- }
    addr1 1+ $10 addr2 1+ over  str>merge
    addr1 $11 + 4 addr2 $11 + over str>merge ;

: my-ip? ( addr u -- addr u flag )
    0 my-ip$ [: rot >r 2over my-ip= r> or ;] $[]map ;
: my-ip-merge ( addr u -- addr u flag )
    0 my-ip$ [: rot >r 2over 2over my-ip= IF
408
	    2over 2swap my-ip>merge rdrop true  ELSE  2drop r>  THEN ;] $[]map ;
bernd's avatar
bernd committed
409

Bernd Paysan's avatar
Bernd Paysan committed
410 411
\ Create udp socket

bernd's avatar
bernd committed
412
4242 Value net2o-port
Bernd Paysan's avatar
Bernd Paysan committed
413

bernd's avatar
bernd committed
414 415
Variable net2o-host "net2o.de" net2o-host $!

416
: net2o-socket ( port -- ) dup >r
417
    create-udp-server46 to net2o-sock
418
    r> ?dup-0=-IF  my-port  THEN to my-port#
bernd's avatar
bernd committed
419
    !my-ips ;
Bernd Paysan's avatar
Bernd Paysan committed
420

bernd's avatar
bernd committed
421
$2A Constant overhead \ constant overhead
bernd's avatar
bernd committed
422
$4 Value max-size^2 \ 1k, don't fragment by default
bernd's avatar
bernd committed
423
$40 Constant min-size
bernd's avatar
bernd committed
424 425
$400000 Value max-data#
$10000 Value max-code#
426
1 Value buffers#
bernd's avatar
bernd committed
427 428 429 430
min-size max-size^2 lshift Value maxdata ( -- n )
maxdata overhead + Value maxpacket
maxpacket $F + -$10 and Value maxpacket-aligned
max-size^2 6 + Value chunk-p2
bernd's avatar
bernd committed
431
$10 Constant mykey-salt#
Bernd Paysan's avatar
Bernd Paysan committed
432

bernd's avatar
bernd committed
433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450
begin-structure timestamp
64field: ts-ticks
end-structure

begin-structure reply
field: reply-len
field: reply-offset
64field: reply-dest
end-structure

m: addr>bits ( addr -- bits )
    chunk-p2 rshift ;
m: addr>bytes ( addr -- bytes )
    chunk-p2 3 + rshift ;
m: bytes>addr ( bytes addr -- )
    chunk-p2 3 + lshift ;
m: bits>bytes ( bits -- bytes )
    1- 2/ 2/ 2/ 1+ ;
bernd's avatar
bernd committed
451 452
m: bytes>bits ( bytes -- bits )
    3 lshift ;
bernd's avatar
bernd committed
453 454 455 456 457 458 459
m: addr>ts ( addr -- ts-offset )
    addr>bits timestamp * ;
m: addr>replies ( addr -- replies )
    addr>bits reply * ;
m: addr>keys ( addr -- keys )
    max-size^2 rshift [ min-size negate ]L and ;

460
sema cmd0lock
bernd's avatar
bernd committed
461

bernd's avatar
bernd committed
462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479
\ generic hooks and user variables

User ind-addr
User reqmask
UDefer other
UValue pollfd#  2 to pollfd#
User pollfds
pollfds pollfd %size pollfd# * dup cell- uallot drop erase

Defer init-reply

: -other        ['] noop is other ;
-other

: fds!+ ( fileno flag addr -- addr' )
    >r r@ events w!  r@ fd l!  r> pollfd %size + ; 

: prep-socks ( -- )  pollfds >r
480
    net2o-sock         POLLIN  r> fds!+ >r
bernd's avatar
bernd committed
481 482
    epiper @    fileno POLLIN  r> fds!+ drop 2 to pollfd# ;

bernd's avatar
bernd committed
483 484 485 486
\ the policy on allocation and freeing is that both freshly allocated
\ and to-be-freed memory is erased.  This makes sure that no unwanted
\ data will be lurking in that memory, waiting to be leaked out

bernd's avatar
bernd committed
487 488
: alloz ( size -- addr )
    dup >r allocate throw dup r> erase ;
489 490 491
: freez ( addr size -- )
    \g erase and then free - for secret stuff
    over swap erase free throw ;
bernd's avatar
bernd committed
492 493 494
: ?free ( addr size -- ) >r
    dup @ IF  dup @ r@ freez off  ELSE  drop  THEN  rdrop ;

495 496 497 498 499
: allo1 ( size -- addr )
    dup >r allocate throw dup r> $FF fill ;
: allocate-bits ( size -- addr )
    dup >r cell+ allo1 dup r> + off ; \ last cell is off

bernd's avatar
bernd committed
500 501 502
\ for bigger blocks, we use use alloc+guard, i.e. mmap with a
\ guard page after the end.

503
: alloc-buf ( -- addr )
bernd's avatar
bernd committed
504
    maxpacket-aligned buffers# * alloc+guard 6 + ;
505 506
: free-buf ( addr -- )
    6 - maxpacket-aligned buffers# * 2dup erase free+guard ;
bernd's avatar
bernd committed
507 508 509 510 511

: ?free+guard ( addr u -- )
    over @ IF  over @ swap 2dup erase  free+guard  off
    ELSE  2drop  THEN ;

512 513 514
: init-statbuf ( -- )
    file-stat alloz to statbuf ;
: free-statbuf ( -- )
515
    statbuf file-stat freez  0 to statbuf ;
bernd's avatar
bernd committed
516

517 518 519 520
ustack string-stack
ustack object-stack
ustack t-stack
ustack nest-stack
bernd's avatar
bernd committed
521

bernd's avatar
bernd committed
522 523 524
: alloc-io ( -- ) \ allocate IO and reset generic user variables
    -other  ind-addr off  reqmask off
    alloc-buf to inbuf  alloc-buf to outbuf
525
    maxdata allocate throw to cmd0buf
bernd's avatar
bernd committed
526
    maxdata 2/ mykey-salt# + $10 + allocate throw to init0buf
bernd's avatar
bernd committed
527 528
    sockaddr_in %size alloz to sockaddr
    sockaddr_in %size alloz to sockaddr1
bernd's avatar
bernd committed
529
    $400 allocate throw to aligned$
bernd's avatar
bernd committed
530
    init-statbuf
531
    init-ed25519 c:init ;
bernd's avatar
bernd committed
532

bernd's avatar
bernd committed
533
: free-io ( -- )
534 535 536
    free-ed25519 c:free
    free-statbuf
    aligned$ $400 freez
bernd's avatar
bernd committed
537 538
    sockaddr  sockaddr_in %size  freez
    sockaddr1 sockaddr_in %size  freez
539 540 541
    init0buf maxdata 2/ mykey-salt# + $10 +  freez
    cmd0buf maxdata   freez
    inbuf  free-buf
542
    outbuf free-buf ;
bernd's avatar
bernd committed
543

bernd's avatar
bernd committed
544
alloc-io
Bernd Paysan's avatar
Bernd Paysan committed
545

bernd's avatar
bernd committed
546
: net2o-pass ( params xt n task )  pass
bernd's avatar
bernd committed
547
    b-out op-vector @ debug-vector !
bernd's avatar
bernd committed
548
    init-reply prep-socks alloc-io catch free-io
bernd's avatar
bernd committed
549
    ?dup-IF  DoError  THEN ;
bernd's avatar
bernd committed
550 551
: net2o-task ( params xt n -- task )
    stacksize4 NewTask4 dup >r net2o-pass r> ;
bernd's avatar
bernd committed
552

bernd's avatar
bernd committed
553 554
\ net2o header structure

555 556 557 558 559
begin-structure net2o-header
    2 +field flags
   16 +field destination
    8 +field addr
end-structure
Bernd Paysan's avatar
Bernd Paysan committed
560

bernd's avatar
bernd committed
561 562
Variable packetr
Variable packets
563 564 565 566
Variable packetr2 \ double received
Variable packets2 \ double send

: .packets ( -- )
bernd's avatar
bernd committed
567 568
    ." IP packets send/received: " packets ? ." (" packets2 ? ." dupes)/"
    packetr ? ." (" packetr2 ? ." dupes) " cr
569
    packets off packetr off packets2 off packetr2 off ;
bernd's avatar
bernd committed
570

bernd's avatar
bernd committed
571
User ptimeout  cell uallot drop
bernd's avatar
bernd committed
572
#10000000 Value poll-timeout# \ 10ms, don't sleep too long
573 574
poll-timeout# 0 ptimeout 2!

575
User socktimeout cell uallot drop
576 577

: sock-timeout! ( socket -- )  fileno
bernd's avatar
bernd committed
578 579 580 581
    socktimeout 2@
    ptimeout 2@ >r 1000 / r> 2dup socktimeout 2! d<> IF
	SOL_SOCKET SO_RCVTIMEO socktimeout 2 cells setsockopt THEN
    drop ;
582

bernd's avatar
bernd committed
583 584
MSG_WAITALL   Constant do-block
MSG_DONTWAIT  Constant don't-block
585

bernd's avatar
bernd committed
586
: read-a-packet ( blockage -- addr u / 0 0 )
bernd's avatar
bernd committed
587
    >r [ sockaddr_in %size ]L alen !
588
    net2o-sock inbuf maxpacket r> sockaddr alen recvfrom
bernd's avatar
bernd committed
589 590 591 592
    dup 0< IF
	errno dup 11 = IF  2drop 0. EXIT  THEN
	512 + negate throw  THEN
    inbuf swap  1 packetr +! ;
Bernd Paysan's avatar
Bernd Paysan committed
593

bernd's avatar
bernd committed
594
$00000000 Value droprate#
bernd's avatar
bernd committed
595

bernd's avatar
bernd committed
596 597 598 599 600 601
: %droprate ( -- )
    1 arg dup 0= IF  2drop  EXIT  THEN
    + 1- c@ '%' <> ?EXIT
    1 arg prefix-number IF  1e fmin 0e fmax $FFFFFFFF fm* f>s to droprate#
	shift-args  THEN ;

bernd's avatar
bernd committed
602
: send-a-packet ( addr u -- n ) +calc
603 604 605
    droprate# IF  rng32 droprate# u< IF
	    \ ." dropping packet" cr
	    2drop 0  EXIT  THEN  THEN
606
    net2o-sock -rot 0 sockaddr alen @ sendto +send 1 packets +! ;
Bernd Paysan's avatar
Bernd Paysan committed
607 608 609

\ clients routing table

bernd's avatar
bernd committed
610
Variable routes
Bernd Paysan's avatar
Bernd Paysan committed
611

bernd's avatar
bernd committed
612
: init-route ( -- )  s" " routes hash@ $! ; \ field 0 is me, myself
Bernd Paysan's avatar
Bernd Paysan committed
613

Bernd Paysan's avatar
Bernd Paysan committed
614
: info>string ( addr -- addr u )
bernd's avatar
bernd committed
615
    dup ai_addr @ swap ai_addrlen l@
bernd's avatar
bernd committed
616 617
    over w@ AF_INET = IF
	drop >r
bernd's avatar
bernd committed
618
	r@ port be-uw@ sockaddr port be-w!
bernd's avatar
bernd committed
619 620
	r> sin_addr be-ul@ sockaddr ipv4!
	sockaddr sock-rest
bernd's avatar
bernd committed
621
    THEN ;
Bernd Paysan's avatar
Bernd Paysan committed
622

bernd's avatar
bernd committed
623
0 Value lastaddr
bernd's avatar
bernd committed
624 625
Variable lastn2oaddr

Bernd Paysan's avatar
Bernd Paysan committed
626
: insert-address ( addr u -- net2o-addr )
627
    address( ." Insert address " 2dup .address cr )
bernd's avatar
bernd committed
628
    lastaddr IF  2dup lastaddr over str=
bernd's avatar
bernd committed
629
	IF  2drop lastn2oaddr @ EXIT  THEN
bernd's avatar
bernd committed
630
    THEN
bernd's avatar
bernd committed
631
    2dup routes #key dup -1 = IF
bernd's avatar
bernd committed
632 633 634
	drop s" " 2over routes #!
	last# $@ drop to lastaddr
	routes #key  dup lastn2oaddr !
bernd's avatar
bernd committed
635 636 637
    ELSE
	nip nip
    THEN ;
638

bernd's avatar
bernd committed
639 640
: insert-ip* ( addr u port hint -- net2o-addr )
    >r SOCK_DGRAM >hints r> hints ai_family l!
Bernd Paysan's avatar
Bernd Paysan committed
641
    get-info info>string insert-address ;
642

bernd's avatar
bernd committed
643 644 645 646
: insert-ip ( addr u port -- net2o-addr )  PF_UNSPEC insert-ip* ;
: insert-ip4 ( addr u port -- net2o-addr ) AF_INET   insert-ip* ;
: insert-ip6 ( addr u port -- net2o-addr ) AF_INET6  insert-ip* ;

Bernd Paysan's avatar
Bernd Paysan committed
647
: address>route ( -- n/-1 )
bernd's avatar
bernd committed
648
    sockaddr alen @ insert-address ;
bernd's avatar
bernd committed
649 650
: route>address ( n -- ) dup >r
    routes #.key dup 0= IF  ." no address: " r> hex. cr drop  EXIT  THEN
bernd's avatar
bernd committed
651
    $@ sockaddr swap dup alen ! move  rdrop ;
Bernd Paysan's avatar
Bernd Paysan committed
652

bernd@vimes's avatar
bernd@vimes committed
653
\ route an incoming packet
Bernd Paysan's avatar
Bernd Paysan committed
654

bernd's avatar
bernd committed
655
User return-addr $10 cell- uallot drop
bernd's avatar
bernd committed
656
User temp-addr   $10 cell- uallot drop
bernd's avatar
bernd committed
657

658 659
\ these are all stubs for now

660 661 662
[IFDEF] 64bit ' be-ux@ [ELSE] ' be-ul@ [THEN] alias be@
[IFDEF] 64bit ' be-x! [ELSE] ' be-l! [THEN] alias be!

663 664 665 666 667 668 669 670 671 672 673 674 675
: >rpath-len ( rpath -- rpath len )
    dup $100 u< IF  1  EXIT  THEN
    dup $10000 u< IF  2  EXIT  THEN
    dup $1000000 u< IF  3  EXIT  THEN
    [IFDEF] 64bit
	dup $100000000 u< IF  4  EXIT  THEN
	dup $10000000000 u< IF  5  EXIT  THEN
	dup $1000000000000 u< IF  6  EXIT  THEN
	dup $100000000000000 u< IF  7  EXIT  THEN
	8
    [ELSE]
	4
    [THEN] ;
bernd's avatar
bernd committed
676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692
: >path-len ( path -- path len )
    dup 0= IF  0  EXIT  THEN
    [IFDEF] 64bit
	dup $00FFFFFFFFFFFFFF and 0= IF  1  EXIT  THEN
	dup $0000FFFFFFFFFFFF and 0= IF  2  EXIT  THEN
	dup $000000FFFFFFFFFF and 0= IF  3  EXIT  THEN
	dup $00000000FFFFFFFF and 0= IF  4  EXIT  THEN
	dup $0000000000FFFFFF and 0= IF  5  EXIT  THEN
	dup $000000000000FFFF and 0= IF  6  EXIT  THEN
	dup $00000000000000FF and 0= IF  7  EXIT  THEN
	8
    [ELSE]
	dup $00FFFFFF and 0= IF  1  EXIT  THEN
	dup $0000FFFF and 0= IF  2  EXIT  THEN
	dup $000000FF and 0= IF  3  EXIT  THEN
	4
    [THEN] ;
693 694 695 696

: <0string ( endaddr -- addr u )
    $11 1 DO  1- dup c@ WHILE  LOOP  $10  ELSE  I  UNLOOP  THEN ;

697
: ins-source ( addr packet -- )
bernd's avatar
bernd committed
698 699 700
    destination >r reverse
    dup >rpath-len { w^ rpath rplen } rpath be!
    r@ $10 + <0string
701
    over rplen - swap move
bernd's avatar
bernd committed
702 703 704 705 706
    rpath cell+ rplen - r> $10 + rplen - rplen move ;
: ins-dest ( n2oaddr destaddr -- )
    >r dup >path-len { w^ path plen } path be!
    r@ cstring>sstring over plen + swap move
    path r> plen move ;
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721
: skip-dest ( addr -- )
    $10 2dup 0 scan nip -
    2dup bounds ?DO
	I c@ $80 u< IF
	    2dup I 1+ -rot >r 2dup - r> swap - dup >r move
	    r> /string  LEAVE  THEN
    LOOP  erase ;

: get-dest ( packet -- addr )  destination dup be@ swap skip-dest ;
: route? ( packet -- flag )  destination c@  ;

: packet-route ( orig-addr addr -- flag )
    dup route?  IF
	>r r@ get-dest  route>address  r> ins-source  false  EXIT  THEN
    2drop true ; \ local packet
bernd@vimes's avatar
bernd@vimes committed
722

Bernd Paysan's avatar
Bernd Paysan committed
723
: in-check ( -- flag )  address>route -1 <> ;
724
: out-route ( -- )  0 outbuf packet-route drop ;
Bernd Paysan's avatar
Bernd Paysan committed
725 726 727

\ packet&header size

728 729 730 731 732 733 734 735 736 737
\ The first byte is organized in a way that works on wired-or busses,
\ e.g. CAN bus, i.e. higher priority and smaller header and data size
\ wins arbitration.  Use MSB first, 0 as dominant bit.

$00 Constant qos0# \ highest priority
$40 Constant qos1#
$80 Constant qos2#
$C0 Constant qos3# \ lowest

$30 Constant headersize#
bernd's avatar
bernd committed
738
$00 Constant 16bit# \ protocol for very small networks
739
$10 Constant 64bit# \ standard, encrypted protocol
740
$0F Constant datasize#
Bernd Paysan's avatar
Bernd Paysan committed
741

bernd's avatar
bernd committed
742
Create header-sizes  $06 c, $1a c, $FF c, $FF c,
bernd's avatar
bernd committed
743
Create tail-sizes    $00 c, $10 c, $FF c, $FF c,
bernd's avatar
bernd committed
744
Create add-sizes     $06 c, $2a c, $FF c, $FF c,
745
\ we don't know the header sizes of protocols 2 and 3 yet ;-)
Bernd Paysan's avatar
Bernd Paysan committed
746

747 748
: header-size ( addr -- n )  c@ headersize# and 4 rshift header-sizes + c@ ;
: tail-size ( addr -- n )  c@ headersize# and 4 rshift tail-sizes + c@ ;
bernd's avatar
bernd committed
749
: add-size ( addr -- n )  c@ headersize# and 4 rshift add-sizes + c@ ;
bernd's avatar
bernd committed
750
: body-size ( addr -- n ) min-size swap c@ datasize# and lshift ;
bernd@vimes's avatar
bernd@vimes committed
751
: packet-size ( addr -- n )
bernd's avatar
bernd committed
752
    dup add-size swap body-size + ;
bernd@vimes's avatar
bernd@vimes committed
753 754
: packet-body ( addr -- addr )
    dup header-size + ;
755 756
: packet-data ( addr -- addr u )
    >r r@ header-size r@ + r> body-size ;
Bernd Paysan's avatar
Bernd Paysan committed
757

bernd's avatar
bernd committed
758 759
add-sizes 1+ c@ min-size + Constant minpacket#

Bernd Paysan's avatar
Bernd Paysan committed
760 761
\ second byte constants

762
$80 Constant broadcasting# \ special flags for switches
Bernd Paysan's avatar
Bernd Paysan committed
763 764
$40 Constant multicasting#

bernd's avatar
bernd committed
765
\ $30 Constant net2o-reserved# - should be 0
Bernd Paysan's avatar
Bernd Paysan committed
766

767
$08 Constant stateless# \ stateless message
768
$07 Constant acks#
769
$01 Constant ack-toggle#
bernd's avatar
bernd committed
770
$02 Constant b2b-toggle#
bernd's avatar
bernd committed
771
$04 Constant resend-toggle#
Bernd Paysan's avatar
Bernd Paysan committed
772

773 774
\ short packet information

775 776 777 778 779
: .header ( addr -- ) base @ >r hex
    dup c@ >r
    min-size r> datasize# and lshift hex. ." bytes to "
    addr 64@ 64. cr
    r> base ! ;
780

Bernd Paysan's avatar
Bernd Paysan committed
781 782
\ each source has multiple destination spaces

bernd's avatar
bernd committed
783
64User dest-addr
784
User dest-flags
Bernd Paysan's avatar
Bernd Paysan committed
785 786

: >ret-addr ( -- )
bernd's avatar
bernd committed
787
    inbuf destination return-addr reverse$16 ;
Bernd Paysan's avatar
Bernd Paysan committed
788
: >dest-addr ( -- )
789 790
    inbuf addr 64@ dest-addr 64!
    inbuf flags w@ dest-flags w! ;
Bernd Paysan's avatar
Bernd Paysan committed
791

bernd's avatar
bernd committed
792 793
current-o

bernd's avatar
bernd committed
794 795
\ job context structure and subclasses

796
object class
bernd's avatar
bernd committed
797
    field: token-table
bernd's avatar
bernd committed
798
    field: parent
799 800
    field: req?
    method start-req
bernd's avatar
bernd committed
801
end-class cmd-class \ command interpreter
802
' noop cmd-class to start-req
bernd's avatar
bernd committed
803 804 805

Variable cmd-table
Variable reply-table
bernd's avatar
bernd committed
806 807 808
Variable log-table
Variable setup-table
Variable ack-table
bernd's avatar
bernd committed
809
Variable msg-table
bernd's avatar
bernd committed
810

bernd's avatar
bernd committed
811
cmd-class class
812
    64field: dest-vaddr
813
    field: dest-size
814
    field: dest-raddr
bernd's avatar
bernd committed
815 816 817
    field: dest-ivs
    field: dest-ivsgen
    field: dest-ivslastgen
818
    field: dest-ivsrest
bernd's avatar
bernd committed
819 820 821 822
    field: dest-timestamps
    field: dest-replies
    field: dest-cookies
    field: dest-round \ going to be obsoleted
bernd's avatar
bernd committed
823
    \                   sender:                receiver:
bernd's avatar
bernd committed
824
    field: dest-top   \ -/-                    sender read up to here
bernd's avatar
bernd committed
825 826 827
    field: dest-head  \ read up to here        received some
    field: dest-tail  \ send from here         received all
    field: dest-back  \ flushed on destination flushed
828
    field: dest-end   \ -/-                    true if last chunk
bernd's avatar
bernd committed
829
    field: do-slurp
bernd's avatar
bernd committed
830
    method free-data
831 832
    method regen-ivs
    method handle
833 834
    method rewind-timestamps
    method rewind-timestamps-partial
835
end-class code-class
836
' drop code-class to regen-ivs
837 838
' noop code-class to rewind-timestamps
' drop code-class to rewind-timestamps-partial
839 840

code-class class end-class data-class
841

842
code-class class
843
    field: data-ackbits
bernd's avatar
bernd committed
844
    field: data-ackbits-buf
bernd's avatar
bernd committed
845
    field: data-ack#     \ fully acked bursts
bernd's avatar
bernd committed
846
    field: ack-bit#      \ actual ack bit
bernd's avatar
bernd committed
847
    field: ack-advance?  \ ack is advancing state
848 849 850
end-class rcode-class

rcode-class class end-class rdata-class
851

bernd's avatar
bernd committed
852 853 854
cmd-class class
    field: timing-stat
    field: track-timing
bernd's avatar
bernd committed
855
    64field: last-time
bernd's avatar
bernd committed
856 857
end-class ack-class

bernd's avatar
bernd committed
858
cmd-class class
bernd's avatar
bernd committed
859
    2field: msg-buf
bernd's avatar
bernd committed
860 861
end-class msg-class

bernd's avatar
bernd committed
862
cmd-class class
bernd's avatar
bernd committed
863 864 865 866
    field: code-map
    field: code-rmap
    field: data-map
    field: data-rmap
bernd's avatar
bernd committed
867 868
    field: log-context
    field: ack-context
bernd's avatar
bernd committed
869
    field: msg-context
bernd's avatar
bernd committed
870
    field: codebuf#
bernd's avatar
bernd committed
871
    field: context#
bernd's avatar
bernd committed
872
    field: wait-task
bernd's avatar
bernd committed
873 874 875 876
    field: resend0
    field: punch-load
    $10 +field return-address \ used as return address
    $10 +field r0-address \ used for resending 0
bernd's avatar
bernd committed
877
    64field: recv-tick
bernd's avatar
bernd committed
878
    64field: recv-addr
bernd's avatar
bernd committed
879 880
    field: recv-flag
    field: file-state
bernd's avatar
bernd committed
881 882
    field: read-file#
    field: write-file#
bernd's avatar
bernd committed
883 884
    field: residualread
    field: residualwrite
bernd's avatar
bernd committed
885 886 887
    field: blocksize
    field: blockalign
    field: crypto-key
888 889
    field: pubkey \ other side official pubkey
    field: mpubkey \ our side official pubkey
bernd's avatar
bernd committed
890 891
    field: timeout-xt \ callback for timeout
    field: setip-xt   \ callback for set-ip
bernd's avatar
bernd committed
892
    field: ack-xt
bernd's avatar
bernd committed
893
    field: request#
894
    field: filereq#
895
    1 pthread-mutexes +field filestate-lock
bernd's avatar
bernd committed
896
    1 pthread-mutexes +field code-lock
897

bernd's avatar
bernd committed
898 899 900
    field: data-resend
    field: data-b2b
    
bernd's avatar
bernd committed
901 902
    cfield: ack-state
    cfield: ack-resend~
bernd's avatar
bernd committed
903
    cfield: ack-resend#
904
    cfield: is-server
bernd's avatar
bernd committed
905 906 907 908 909
    field: ack-receive
    
    field: req-codesize
    field: req-datasize
    \ flow control, sender part
910 911 912 913 914
    field: window-size \ packets in flight
    field: timeouts
    field: flyburst
    field: flybursts

bernd's avatar
bernd committed
915 916 917 918 919 920 921 922 923 924
    64field: min-slack
    64field: max-slack
    64field: ns/burst
    64field: last-ns/burst
    64field: extra-ns
    64field: bandwidth-tick \ ns
    64field: next-tick \ ns
    64field: next-timeout \ ns
    64field: rtdelay \ ns
    64field: lastack \ ns
bernd's avatar
bernd committed
925
    64field: resend-all-to \ ns
bernd's avatar
bernd committed
926 927 928 929 930 931 932 933 934
    64field: lastslack
    64field: lastdeltat
    64field: slackgrow
    64field: slackgrow'
    \ flow control, receiver part
    64field: burst-ticks
    64field: firstb-ticks
    64field: lastb-ticks
    64field: delta-ticks
bernd's avatar
bernd committed
935
    64field: max-dticks
bernd's avatar
bernd committed
936 937 938
    64field: last-rate
    \ experiment: track previous b2b-start
    64field: last-rtick
bernd's avatar
bernd committed
939
    64field: last-raddr
bernd's avatar
bernd committed
940 941
    field: acks
    field: received
bernd's avatar
bernd committed
942 943 944
    \ cookies
    field: last-ackaddr
    \ statistics
945
    64field: time-offset  \ make timestamps smaller
bernd's avatar
bernd committed
946 947
    KEYBYTES +field tpkc
    KEYBYTES +field tskc
948
    field: dest-pubkey  \ if not 0, connect only to this key
949
end-class context-class
Bernd Paysan's avatar
Bernd Paysan committed
950

951 952
Variable context-table

953 954 955 956 957
begin-structure timestats
sffield: ts-delta
sffield: ts-slack
sffield: ts-reqrate
sffield: ts-rate
bernd's avatar
bernd committed
958
sffield: ts-grow
959 960
end-structure

961 962
\ check for valid destination

bernd's avatar
bernd committed
963 964 965
: >data-head ( addr o:map -- flag )  dest-size @ 1- >r
    dup dest-back @ r@ and < IF  r@ + 1+  THEN
    maxdata + dest-back @ r> invert and + dup dest-head umax!@ <> ;
966

967 968
Variable dest-map s" " dest-map $!

bernd's avatar
bernd committed
969 970 971 972 973 974 975 976 977 978 979 980 981 982 983
$100 Value dests#
56 Value dests>>

: set-dests# ( bits -- )
    1 over lshift to dests#
    64 swap - to dests>>
    dests# 2* cells dest-map $!len
    dest-map $@ erase ;

8 set-dests#

: >dest-map ( vaddr -- addr )
    dests>> 64rshift 64>n 2* cells dest-map $@ drop + ;
: dest-index ( -- addr ) dest-addr 64@ >dest-map ;

984
: check-dest ( -- addr map o:job / f )
985 986
    \G return false if invalid destination
    \G return 1 if code, -1 if data, plus destination address
bernd's avatar
bernd committed
987
    dest-index 2 cells bounds ?DO
988
	I @ IF
989 990
	    dest-addr 64@ I @ >o dest-vaddr 64@ 64- 64>n dup
	    dest-size @ u<
991
	    IF
bernd's avatar
bernd committed
992
		dup addr>bits ack-bit# !
bernd's avatar
bernd committed
993
		dest-raddr @ swap dup >data-head ack-advance? ! +
bernd's avatar
bernd committed
994
		o parent @ o> >o rdrop
995
		UNLOOP  EXIT  THEN
996
	    drop o>
997
	THEN
998 999 1000
    cell +LOOP
    false ;

1001
\ context debugging
bernd's avatar
bernd committed
1002

1003 1004
: .o ( -- ) context# ? ;
: o? ( -- ) ]] o 0= ?EXIT [[ ; immediate
bernd's avatar
bernd committed
1005

bernd's avatar
bernd committed
1006 1007 1008 1009 1010
\ Destination mapping contains
\ addr u - range of virtal addresses
\ addr' - real start address
\ context - for exec regions, this is the job context

1011
User >code-flag
bernd's avatar
bernd committed
1012

bernd's avatar
bernd committed
1013
: alloc-data ( addr u -- u flag )
1014
    dup >r dest-size ! dest-vaddr 64! r>
bernd's avatar
bernd committed
1015
    dup alloc+guard dest-raddr !
bernd's avatar
bernd committed
1016
    c:key# alloz dest-ivsgen !
1017
    >code-flag @
1018
    IF
bernd's avatar
bernd committed
1019
	dup addr>replies  alloz dest-replies !
bernd's avatar
bernd committed
1020
	3 dest-ivslastgen !
1021
    ELSE
bernd's avatar
bernd committed
1022
	dup addr>ts       alloz dest-timestamps !
bernd's avatar
bernd committed
1023 1024 1025
    THEN ;

: map-data ( addr u -- o )
bernd's avatar
bernd committed
1026
    o >code-flag @ IF rcode-class ELSE rdata-class THEN new >o parent !
bernd's avatar
bernd committed
1027
    alloc-data
1028
    >code-flag @ 0= IF
bernd's avatar
bernd committed
1029
	dup addr>ts alloz dest-cookies !
bernd's avatar
bernd committed
1030
	dup addr>bytes allocate-bits data-ackbits !
1031
    THEN
bernd's avatar
bernd committed
1032
    drop
1033
    o o> ;
bernd's avatar
bernd committed
1034

1035
: map-source ( addr u addrx -- o )
bernd's avatar
bernd committed
1036
    o >code-flag @ IF code-class ELSE data-class THEN new >o parent !
bernd's avatar
bernd committed
1037
    alloc-data
bernd's avatar
bernd committed
1038
    dup addr>ts alloz dest-cookies !
bernd's avatar
bernd committed
1039
    drop
1040 1041 1042
    o o> ;

' @ Alias m@
bernd's avatar
bernd committed
1043

bernd's avatar
bernd committed
1044
: map-data-dest ( vaddr u addr -- )
1045
    >r >r 64dup r> map-data r@ ! >dest-map r> @ swap ! ;
bernd's avatar
bernd committed
1046
: map-code-dest ( vaddr u addr -- )
1047
    >r >r 64dup r> map-data r@ ! >dest-map cell+ r> @ swap ! ;
bernd's avatar
bernd committed
1048 1049 1050

\ create context

bernd's avatar
bernd committed
1051
4 Value bursts# \ number of 
bernd's avatar
bernd committed
1052
8 Value delta-damp# \ for clocks with a slight drift