net2o.fs 70.4 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 threefish.fs
bernd's avatar
bernd committed
37
\ require wurstkessel.fs
bernd's avatar
bernd committed
38
keccak-o crypto-o !
39
require rng.fs
40
require ed25519-donna.fs
bernd's avatar
bernd committed
41
require hash-table.fs
42

bernd's avatar
bernd committed
43 44 45
\ user values

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

bernd's avatar
bernd committed
55 56
[IFDEF] 64bit
    ' min! Alias 64min!
bernd's avatar
bernd committed
57
    ' max! Alias 64max!
bernd's avatar
bernd committed
58 59
    ' umin! Alias 64umin!
    ' umax! Alias 64umax!
bernd's avatar
bernd committed
60
    ' !@ Alias 64!@
bernd's avatar
bernd committed
61
[ELSE]
62 63
    : 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
64
    : 64!@ ( value addr -- old-value )   >r r@ 64@ 64swap r> 64! ;
bernd's avatar
bernd committed
65
    : 64min! ( d addr -- )  >r r@ 64@ dmin r> 64! ;
bernd's avatar
bernd committed
66
    : 64max! ( d addr -- )  >r r@ 64@ dmax r> 64! ;
bernd's avatar
bernd committed
67 68
    : 64umin! ( n addr -- )   >r r@ 64@ dumin r> 64! ;
    : 64umax! ( n addr -- )   >r r@ 64@ dumin r> 64! ;
bernd's avatar
bernd committed
69 70
[THEN]

71
\ bit vectors, lsb first
bernd's avatar
bernd committed
72

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

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

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

: 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
104 105
\ variable length integers

bernd's avatar
bernd committed
106
[IFDEF] 64bit
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
    : 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
127
	BEGIN  7 64lshift r@ c@ $7F and 0 64or r@ c@ $80 and  WHILE
128 129 130 131 132 133 134 135 136 137 138 139 140
		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
141 142
	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
143 144
	2drop rdrop r> ;
[THEN]
bernd's avatar
bernd committed
145

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

bernd's avatar
bernd committed
148 149 150 151 152 153 154 155
\ 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
156
: reverse ( x1 -- x2 )
bernd's avatar
bernd committed
157
    0 cell 0 DO  8 lshift over $FF and reverse8 or
bernd's avatar
bernd committed
158
       swap 8 rshift swap  LOOP  nip ;
bernd's avatar
bernd committed
159 160 161 162 163 164 165 166
: 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
167
    c@    reverse8 r> $8 + c@ reverse8 dst 7 + c! dst $8 + c! ;
bernd's avatar
bernd committed
168 169

\ IP address stuff
bernd's avatar
bernd committed
170 171

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

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

bernd's avatar
bernd committed
178 179 180 181 182 183
\ 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
184 185 186
\ Symbolic name may start with '@'+len followed by the name

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

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

bernd's avatar
bernd committed
193 194 195 196 197
default-host

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

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

bernd's avatar
bernd committed
203 204 205
Create sockaddr" 2 c, $16 allot

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

222
: .port ( addr len -- addr' len' )
223 224
    ." :" over be-uw@ 0 ['] .r #10 base-execute  2 /string ;
: .net2o ( addr u -- ) dup IF  ." |" xtype  ELSE  2drop  THEN ;
bernd's avatar
bernd committed
225 226
: .ip4b ( addr len -- addr' len' )
    over c@ 0 ['] .r #10 base-execute 1 /string ;
bernd's avatar
bernd committed
227 228
: .ip4a ( addr len -- addr' len' )
    .ip4b ." ." .ip4b ." ." .ip4b ." ." .ip4b ;
bernd's avatar
bernd committed
229
: .ip4 ( addr len -- )
230
    .ip4a .port .net2o ;
bernd's avatar
bernd committed
231 232 233 234 235
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
236 237
: .ip6a ( addr len -- addr' len' )
    2dup fake-ip4 12 string-prefix? IF  12 /string .ip4a  EXIT  THEN
bernd's avatar
bernd committed
238 239
    -1 ip6:# !
    '[' 8 0 DO  ip6:# @ 2 < IF  emit  ELSE drop  THEN .ip6w ':'  LOOP
240
    drop ." ]" ;
bernd's avatar
bernd committed
241 242
: .ip6 ( addr len -- )
    .ip6a .port .net2o ;
bernd's avatar
bernd committed
243

bernd's avatar
bernd committed
244
: .ip64 ( addr len -- )
bernd's avatar
bernd committed
245 246 247
    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
248 249

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

\ NAT traversal stuff: print IP addresses

bernd's avatar
bernd committed
257
: skip-symname ( addr u -- addr' u' )
bernd's avatar
bernd committed
258
    over c@ '0' = IF  2 safe/string  THEN
bernd's avatar
bernd committed
259 260
    over c@ '?' - 0 max safe/string ;
: .symname ( addr u -- addr' u' )
bernd's avatar
bernd committed
261
    over c@ '0' = IF  over 1+ c@ 0 .r '#' emit  2 safe/string  THEN
bernd's avatar
bernd committed
262 263 264 265
    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
266
    case  over c@ >r 1 /string r>
bernd's avatar
bernd committed
267 268
	'1' of  ." |" xtype  endof
	'2' of  .ip64 endof
bernd's avatar
bernd committed
269
	dup emit -rot dump endcase ;
bernd's avatar
bernd committed
270

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

bernd's avatar
bernd committed
273 274 275 276 277
: 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
278

bernd's avatar
bernd committed
279 280 281 282 283
: 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
284

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

bernd's avatar
bernd committed
290 291 292 293 294
: 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
295 296
: 'sock ( xt -- )  sock[ catch ]sock throw ;

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

bernd's avatar
bernd committed
301
: check-ip4 ( ip4addr -- my-ip4addr 4 ) noipv4( 0 EXIT )
bernd's avatar
bernd committed
302
    [:  sockaddr_in6 %size alen !
303
	sockaddr ipv4! query-sock sockaddr sock-rest connect
bernd's avatar
bernd committed
304 305 306 307 308 309
	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
310

bernd's avatar
bernd committed
311 312
$25DDC249 Constant dummy-ipv4 \ this is my net2o ipv4 address
Create dummy-ipv6 \ this is my net2o ipv6 address
313 314
$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
315
Create local-ipv6
bernd's avatar
bernd committed
316
$FD c, $00 c, $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $0000 w, $0100 w,
bernd's avatar
bernd committed
317

bernd's avatar
bernd committed
318 319
0 Value my-port#

bernd's avatar
bernd committed
320
: check-ip6 ( dummy -- ip6addr u ) noipv6( 0 EXIT )
321
    \G return IPv6 address - if length is 0, not reachable with IPv6
bernd's avatar
bernd committed
322 323
    [:  sockaddr_in6 %size alen !
	sockaddr sin6_addr $10 move
bernd's avatar
bernd committed
324 325 326 327 328 329
	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
330

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

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

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

bernd's avatar
bernd committed
342 343
\ insert into sorted string array

bernd's avatar
bernd committed
344 345 346 347 348
: $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
349
		drop $# $a $[]!  EXIT  THEN
bernd's avatar
bernd committed
350 351
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
352
    0 { w^ ins$0 } ins$0 cell $a r@ cells $ins r> $a $[]! ;
bernd's avatar
bernd committed
353 354 355 356 357 358 359 360 361 362 363
: $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
364 365
\ add IP addresses

bernd's avatar
bernd committed
366 367
Variable myname

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

bernd's avatar
bernd committed
374 375 376
Variable $tmp2

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

bernd's avatar
bernd committed
381 382
\ this looks ok

bernd's avatar
bernd committed
383 384 385 386
: && ( 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

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

bernd's avatar
bernd committed
391
: my-ip= skip-symname 2swap skip-symname { addr1 u1 addr2 u2 -- flag }
bernd's avatar
bernd committed
392 393 394 395 396 397 398 399
    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 ;

400 401
: my-ip>merge ( addr1 u1 addr2 u2 -- )
    skip-symname 2swap skip-symname 2swap
bernd's avatar
bernd committed
402 403 404 405 406 407 408 409
    { 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
bernd's avatar
bernd committed
410
	  2over 2swap my-ip>merge rdrop true  ELSE  2drop r>  THEN ;] $[]map ;
bernd's avatar
bernd committed
411

Bernd Paysan's avatar
Bernd Paysan committed
412 413
\ Create udp socket

bernd's avatar
bernd committed
414
4242 Value net2o-port
Bernd Paysan's avatar
Bernd Paysan committed
415

bernd's avatar
bernd committed
416 417
Variable net2o-host "net2o.de" net2o-host $!

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

bernd's avatar
bernd committed
423
$2A Constant overhead \ constant overhead
bernd's avatar
bernd committed
424
$4 Value max-size^2 \ 1k, don't fragment by default
bernd's avatar
bernd committed
425
$40 Constant min-size
bernd's avatar
bernd committed
426 427
$400000 Value max-data#
$10000 Value max-code#
428
1 Value buffers#
bernd's avatar
bernd committed
429 430 431 432
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
433
$10 Constant mykey-salt#
Bernd Paysan's avatar
Bernd Paysan committed
434

bernd's avatar
bernd committed
435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
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
453 454
m: bytes>bits ( bytes -- bits )
    3 lshift ;
bernd's avatar
bernd committed
455 456 457 458 459 460 461
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 ;

462
sema cmd0lock
bernd's avatar
bernd committed
463

bernd's avatar
bernd committed
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481
\ 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
482
    net2o-sock         POLLIN  r> fds!+ >r
bernd's avatar
bernd committed
483 484
    epiper @    fileno POLLIN  r> fds!+ drop 2 to pollfd# ;

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

497 498 499 500 501
: 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
502 503 504
\ for bigger blocks, we use use alloc+guard, i.e. mmap with a
\ guard page after the end.

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

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

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

519 520 521 522
ustack string-stack
ustack object-stack
ustack t-stack
ustack nest-stack
bernd's avatar
bernd committed
523

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

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

bernd's avatar
bernd committed
549
alloc-io
Bernd Paysan's avatar
Bernd Paysan committed
550

551 552
Variable net2o-tasks

bernd's avatar
bernd committed
553 554
: net2o-pass ( params xt n task -- )
    dup { w^ task }
555
    task cell net2o-tasks $+!  pass
bernd's avatar
bernd committed
556
    b-out op-vector @ debug-vector !
bernd's avatar
bernd committed
557 558 559
    init-reply prep-socks alloc-io catch
    1+ ?dup-IF  free-io 1- ?dup-IF  DoError  THEN
    ELSE  ~~ 0 (bye) ~~  THEN ;
bernd's avatar
bernd committed
560 561
: net2o-task ( params xt n -- task )
    stacksize4 NewTask4 dup >r net2o-pass r> ;
bernd's avatar
bernd committed
562
event: ->kill:n2o ( -- )  -1 throw ;
563 564 565 566 567 568
: net2o-kills ( -- )
    net2o-tasks $@ bounds ?DO
	I @ <event ->kill event>
    cell +LOOP  net2o-tasks $off
    ." Killed everything" cr 10 ms ." done waiting" cr ;

bernd's avatar
bernd committed
569 570
true value net2o-running

571
0 warnings !@
bernd's avatar
bernd committed
572
: net2o-bye false to net2o-running ['] noop is kill-task  bye ;
573
warnings !
bernd's avatar
bernd committed
574

bernd's avatar
bernd committed
575 576
\ net2o header structure

577 578 579 580 581
begin-structure net2o-header
    2 +field flags
   16 +field destination
    8 +field addr
end-structure
Bernd Paysan's avatar
Bernd Paysan committed
582

bernd's avatar
bernd committed
583 584
Variable packetr
Variable packets
585 586 587 588
Variable packetr2 \ double received
Variable packets2 \ double send

: .packets ( -- )
bernd's avatar
bernd committed
589 590
    ." IP packets send/received: " packets ? ." (" packets2 ? ." dupes)/"
    packetr ? ." (" packetr2 ? ." dupes) " cr
591
    packets off packetr off packets2 off packetr2 off ;
bernd's avatar
bernd committed
592

bernd's avatar
bernd committed
593
User ptimeout  cell uallot drop
bernd's avatar
bernd committed
594
#10000000 Value poll-timeout# \ 10ms, don't sleep too long
595 596
poll-timeout# 0 ptimeout 2!

597
User socktimeout cell uallot drop
598 599

: sock-timeout! ( socket -- )  fileno
bernd's avatar
bernd committed
600 601 602 603
    socktimeout 2@
    ptimeout 2@ >r 1000 / r> 2dup socktimeout 2! d<> IF
	SOL_SOCKET SO_RCVTIMEO socktimeout 2 cells setsockopt THEN
    drop ;
604

bernd's avatar
bernd committed
605 606
MSG_WAITALL   Constant do-block
MSG_DONTWAIT  Constant don't-block
607

bernd's avatar
bernd committed
608
: read-a-packet ( blockage -- addr u / 0 0 )
bernd's avatar
bernd committed
609
    >r [ sockaddr_in %size ]L alen !
610
    net2o-sock inbuf maxpacket r> sockaddr alen recvfrom
bernd's avatar
bernd committed
611 612 613 614
    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
615

bernd's avatar
bernd committed
616
$00000000 Value droprate#
bernd's avatar
bernd committed
617

bernd's avatar
bernd committed
618 619 620 621 622 623
: %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
624
: send-a-packet ( addr u -- n ) +calc
625 626 627
    droprate# IF  rng32 droprate# u< IF
	    \ ." dropping packet" cr
	    2drop 0  EXIT  THEN  THEN
628
    net2o-sock -rot 0 sockaddr alen @ sendto +send 1 packets +! ;
Bernd Paysan's avatar
Bernd Paysan committed
629 630 631

\ clients routing table

bernd's avatar
bernd committed
632
Variable routes
Bernd Paysan's avatar
Bernd Paysan committed
633

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

Bernd Paysan's avatar
Bernd Paysan committed
636
: info>string ( addr -- addr u )
bernd's avatar
bernd committed
637
    dup ai_addr @ swap ai_addrlen l@
bernd's avatar
bernd committed
638 639
    over w@ AF_INET = IF
	drop >r
bernd's avatar
bernd committed
640
	r@ port be-uw@ sockaddr port be-w!
bernd's avatar
bernd committed
641 642
	r> sin_addr be-ul@ sockaddr ipv4!
	sockaddr sock-rest
bernd's avatar
bernd committed
643
    THEN ;
Bernd Paysan's avatar
Bernd Paysan committed
644

bernd's avatar
bernd committed
645
0 Value lastaddr
bernd's avatar
bernd committed
646 647
Variable lastn2oaddr

Bernd Paysan's avatar
Bernd Paysan committed
648
: insert-address ( addr u -- net2o-addr )
649
    address( ." Insert address " 2dup .address cr )
bernd's avatar
bernd committed
650
    lastaddr IF  2dup lastaddr over str=
bernd's avatar
bernd committed
651
	IF  2drop lastn2oaddr @ EXIT  THEN
bernd's avatar
bernd committed
652
    THEN
bernd's avatar
bernd committed
653
    2dup routes #key dup -1 = IF
bernd's avatar
bernd committed
654 655 656
	drop s" " 2over routes #!
	last# $@ drop to lastaddr
	routes #key  dup lastn2oaddr !
bernd's avatar
bernd committed
657 658 659
    ELSE
	nip nip
    THEN ;
660

bernd's avatar
bernd committed
661 662
: insert-ip* ( addr u port hint -- net2o-addr )
    >r SOCK_DGRAM >hints r> hints ai_family l!
Bernd Paysan's avatar
Bernd Paysan committed
663
    get-info info>string insert-address ;
664

bernd's avatar
bernd committed
665 666 667 668
: 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
669
: address>route ( -- n/-1 )
bernd's avatar
bernd committed
670
    sockaddr alen @ insert-address ;
bernd's avatar
bernd committed
671 672
: route>address ( n -- ) dup >r
    routes #.key dup 0= IF  ." no address: " r> hex. cr drop  EXIT  THEN
bernd's avatar
bernd committed
673
    $@ sockaddr swap dup alen ! move  rdrop ;
Bernd Paysan's avatar
Bernd Paysan committed
674

bernd@vimes's avatar
bernd@vimes committed
675
\ route an incoming packet
Bernd Paysan's avatar
Bernd Paysan committed
676

bernd's avatar
bernd committed
677
User return-addr $10 cell- uallot drop
bernd's avatar
bernd committed
678
User temp-addr   $10 cell- uallot drop
bernd's avatar
bernd committed
679

680 681
\ these are all stubs for now

682 683 684
[IFDEF] 64bit ' be-ux@ [ELSE] ' be-ul@ [THEN] alias be@
[IFDEF] 64bit ' be-x! [ELSE] ' be-l! [THEN] alias be!

685 686 687 688 689 690 691 692 693 694 695 696 697
: >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
698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714
: >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] ;
715 716 717 718

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

719
: ins-source ( addr packet -- )
bernd's avatar
bernd committed
720 721 722
    destination >r reverse
    dup >rpath-len { w^ rpath rplen } rpath be!
    r@ $10 + <0string
723
    over rplen - swap move
bernd's avatar
bernd committed
724 725 726 727 728
    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 ;
729 730 731 732 733 734 735 736 737 738 739 740 741 742 743
: 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
744

Bernd Paysan's avatar
Bernd Paysan committed
745
: in-check ( -- flag )  address>route -1 <> ;
746
: out-route ( -- )  0 outbuf packet-route drop ;
Bernd Paysan's avatar
Bernd Paysan committed
747 748 749

\ packet&header size

750 751 752 753 754 755 756 757 758 759
\ 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
760
$00 Constant 16bit# \ protocol for very small networks
761
$10 Constant 64bit# \ standard, encrypted protocol
762
$0F Constant datasize#
Bernd Paysan's avatar
Bernd Paysan committed
763

bernd's avatar
bernd committed
764
Create header-sizes  $06 c, $1a c, $FF c, $FF c,
bernd's avatar
bernd committed
765
Create tail-sizes    $00 c, $10 c, $FF c, $FF c,
bernd's avatar
bernd committed
766
Create add-sizes     $06 c, $2a c, $FF c, $FF c,
767
\ we don't know the header sizes of protocols 2 and 3 yet ;-)
Bernd Paysan's avatar
Bernd Paysan committed
768

769 770
: 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
771
: add-size ( addr -- n )  c@ headersize# and 4 rshift add-sizes + c@ ;
bernd's avatar
bernd committed
772
: body-size ( addr -- n ) min-size swap c@ datasize# and lshift ;
bernd@vimes's avatar
bernd@vimes committed
773
: packet-size ( addr -- n )
bernd's avatar
bernd committed
774
    dup add-size swap body-size + ;
bernd@vimes's avatar
bernd@vimes committed
775 776
: packet-body ( addr -- addr )
    dup header-size + ;
777 778
: packet-data ( addr -- addr u )
    >r r@ header-size r@ + r> body-size ;
Bernd Paysan's avatar
Bernd Paysan committed
779

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

Bernd Paysan's avatar
Bernd Paysan committed
782 783
\ second byte constants

784
$80 Constant broadcasting# \ special flags for switches
Bernd Paysan's avatar
Bernd Paysan committed
785 786
$40 Constant multicasting#

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

789
$08 Constant stateless# \ stateless message
790
$07 Constant acks#
791
$01 Constant ack-toggle#
bernd's avatar
bernd committed
792
$02 Constant b2b-toggle#
bernd's avatar
bernd committed
793
$04 Constant resend-toggle#
Bernd Paysan's avatar
Bernd Paysan committed
794

795 796
\ short packet information

797 798 799 800 801
: .header ( addr -- ) base @ >r hex
    dup c@ >r
    min-size r> datasize# and lshift hex. ." bytes to "
    addr 64@ 64. cr
    r> base ! ;
802

Bernd Paysan's avatar
Bernd Paysan committed
803 804
\ each source has multiple destination spaces

bernd's avatar
bernd committed
805
64User dest-addr
806
User dest-flags
Bernd Paysan's avatar
Bernd Paysan committed
807 808

: >ret-addr ( -- )
bernd's avatar
bernd committed
809
    inbuf destination return-addr reverse$16 ;
Bernd Paysan's avatar
Bernd Paysan committed
810
: >dest-addr ( -- )
811 812
    inbuf addr 64@ dest-addr 64!
    inbuf flags w@ dest-flags w! ;
Bernd Paysan's avatar
Bernd Paysan committed
813

bernd's avatar
bernd committed
814 815
current-o

bernd's avatar
bernd committed
816 817
\ job context structure and subclasses

bernd's avatar
bernd committed
818 819
Variable contexts \G contains all command objects

820
object class
bernd's avatar
bernd committed
821
    field: token-table
bernd's avatar
bernd committed
822
    field: parent
823 824
    field: req?
    method start-req
bernd's avatar
bernd committed
825
end-class cmd-class \ command interpreter
826
' noop cmd-class to start-req
bernd's avatar
bernd committed
827 828 829

Variable cmd-table
Variable reply-table
bernd's avatar
bernd committed
830 831 832
Variable log-table
Variable setup-table
Variable ack-table
bernd's avatar
bernd committed
833
Variable msg-table
bernd's avatar
bernd committed
834
Variable term-table
bernd's avatar
bernd committed
835

bernd's avatar
bernd committed
836
cmd-class class
837
    64field: dest-vaddr
838
    field: dest-size
839
    field: dest-raddr
bernd's avatar
bernd committed
840 841 842
    field: dest-ivs
    field: dest-ivsgen
    field: dest-ivslastgen
843
    field: dest-ivsrest
bernd's avatar
bernd committed
844 845 846 847
    field: dest-timestamps
    field: dest-replies
    field: dest-cookies
    field: dest-round \ going to be obsoleted
bernd's avatar
bernd committed
848
    \                   sender:                receiver:
bernd's avatar
bernd committed
849
    field: dest-top   \ -/-                    sender read up to here
bernd's avatar
bernd committed
850 851 852
    field: dest-head  \ read up to here        received some
    field: dest-tail  \ send from here         received all
    field: dest-back  \ flushed on destination flushed
853
    field: dest-end   \ -/-                    true if last chunk
bernd's avatar
bernd committed
854
    field: do-slurp
bernd's avatar
bernd committed
855
    method free-data
856 857
    method regen-ivs
    method handle
858 859
    method rewind-timestamps
    method rewind-timestamps-partial
860
end-class code-class
861
' drop code-class to regen-ivs
862 863
' noop code-class to rewind-timestamps
' drop code-class to rewind-timestamps-partial
864 865

code-class class end-class data-class
866

867
code-class class
868
    field: data-ackbits
bernd's avatar
bernd committed
869
    field: data-ackbits-buf
bernd's avatar
bernd committed
870
    field: data-ack#     \ fully acked bursts
bernd's avatar
bernd committed
871
    field: ack-bit#      \ actual ack bit
bernd's avatar
bernd committed
872
    field: ack-advance?  \ ack is advancing state
873 874 875
end-class rcode-class

rcode-class class end-class rdata-class
876

bernd's avatar
bernd committed
877 878 879
cmd-class class
    field: timing-stat
    field: track-timing
880 881 882
    field: flyburst
    field: flybursts
    field: timeouts
bernd's avatar
bernd committed
883
    field: window-size \ packets in flight
884
    64field: rtdelay \ ns
bernd's avatar
bernd committed
885
    64field: last-time
886 887
    64field: lastack \ ns
    64field: recv-tick
bernd's avatar
bernd committed
888 889
    64field: ns/burst
    64field: last-ns/burst
bernd's avatar
bernd committed
890 891
    64field: bandwidth-tick \ ns
    64field: next-tick \ ns
bernd's avatar
bernd committed
892
    64field: extra-ns
bernd's avatar
bernd committed
893 894
    64field: slackgrow
    64field: slackgrow'
bernd's avatar
bernd committed
895 896 897
    64field: lastslack
    64field: min-slack
    64field: max-slack
bernd's avatar
bernd committed
898 899
    64field: time-offset  \ make timestamps smaller
    64field: lastdeltat
bernd's avatar
bernd committed
900 901
end-class ack-class

bernd's avatar
bernd committed
902
cmd-class class
bernd's avatar
bernd committed
903
    2field: msg-buf
bernd's avatar
bernd committed
904 905
end-class msg-class

bernd's avatar
bernd committed
906 907
cmd-class class
    \ maps for data and code transfer
bernd's avatar
bernd committed
908 909 910 911
    field: code-map
    field: code-rmap
    field: data-map
    field: data-rmap
bernd's avatar
bernd committed
912 913
    \ contexts for subclasses
    field: next-context \ link field to connect all contexts
bernd's avatar
bernd committed
914 915
    field: log-context
    field: ack-context
bernd's avatar
bernd committed
916
    field: msg-context
917
    field: file-state \ files
bernd's avatar
bernd committed
918
    \ rest of state
bernd's avatar
bernd committed
919
    field: codebuf#
bernd's avatar
bernd committed
920
    field: context#
bernd's avatar
bernd committed
921
    field: wait-task
bernd's avatar
bernd committed
922 923 924 925
    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
926
    64field: recv-addr
bernd's avatar
bernd committed
927
    field: recv-flag
bernd's avatar
bernd committed
928 929
    field: read-file#
    field: write-file#
bernd's avatar
bernd committed
930 931
    field: residualread
    field: residualwrite
bernd's avatar
bernd committed
932 933 934
    field: blocksize
    field: blockalign
    field: crypto-key
935 936
    field: pubkey \ other side official pubkey
    field: mpubkey \ our side official pubkey
bernd's avatar
bernd committed
937 938
    field: timeout-xt \ callback for timeout
    field: setip-xt   \ callback for set-ip
939
    field: ack-xt     \ callback for acknowledge
bernd's avatar
bernd committed
940
    field: request#
941
    field: filereq#
942
    1 pthread-mutexes +field filestate-lock
bernd's avatar
bernd committed
943
    1 pthread-mutexes +field code-lock
944

bernd's avatar
bernd committed
945 946 947
    field: data-resend
    field: data-b2b
    
bernd's avatar
bernd committed
948 949
    cfield: ack-state
    cfield: ack-resend~
bernd's avatar
bernd committed
950
    cfield: ack-resend#
951
    cfield: is-server
bernd's avatar
bernd committed
952 953 954 955 956
    field: ack-receive
    
    field: req-codesize
    field: req-datasize
    \ flow control, sender part
957

bernd's avatar
bernd committed
958
    64field: next-timeout \ ns
bernd's avatar
bernd committed
959
    64field: resend-all-to \ ns
bernd's avatar
bernd committed
960 961 962 963 964
    \ flow control, receiver part
    64field: burst-ticks
    64field: firstb-ticks
    64field: lastb-ticks
    64field: delta-ticks
bernd's avatar
bernd committed
965
    64field: max-dticks
bernd's avatar
bernd committed
966 967 968
    64field: last-rate
    \ experiment: track previous b2b-start
    64field: last-rtick
bernd's avatar
bernd committed
969
    64field: last-raddr
bernd's avatar
bernd committed
970 971
    field: acks
    field: received
bernd's avatar
bernd committed
972 973 974
    \ cookies
    field: last-ackaddr
    \ statistics
bernd's avatar
bernd committed
975 976
    KEYBYTES +field tpkc
    KEYBYTES +field tskc
977
    field: dest-pubkey  \ if not 0, connect only to this key
978
    field: dest-0key    \ key for stateless connections
979
end-class context-class
Bernd Paysan's avatar
Bernd Paysan committed
980

981 982
Variable context-table

983 984 985 986 987
begin-structure timestats
sffield: ts-delta
sffield: ts-slack
sffield: ts-reqrate
sffield: ts-rate
bernd's avatar
bernd committed
988
sffield: ts-grow
989 990
end-structure

991 992
\ check for valid destination

bernd's avatar
bernd committed
993 994 995
: >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!@ <> ;
996

997 998
Variable dest-map s" " dest-map $!

bernd's avatar
bernd committed
999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013
$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 ;

1014
: check-dest ( -- addr map o:job / f )
1015 1016
    \G return false if invalid destination
    \G return 1 if code, -1 if data, plus destination address
bernd's avatar
bernd committed
1017
    dest-index 2 cells bounds ?DO
1018
	I @ IF
1019 1020
	    dest-addr 64@ I @ >o dest-vaddr 64@ 64- 64>n dup
	    dest-size @ u<
1021
	    IF
bernd's avatar
bernd committed
1022
		dup addr>bits ack-bit# !
bernd's avatar
bernd committed
1023
		dest-raddr @ swap dup >data-head ack-advance? ! +
bernd's avatar
bernd committed
1024
		o parent @ o> >o rdrop
1025
		UNLOOP  EXIT  THEN
1026
	    drop o>
1027
	THEN
1028 1029 1030
    cell +LOOP
    false ;

1031
\ context debugging
bernd's avatar
bernd committed
1032

1033 1034
: .o ( -- ) context# ? ;
: o? ( -- ) ]] o 0= ?EXIT [[ ; immediate
bernd's avatar
bernd committed
1035

bernd's avatar
bernd committed
1036 1037 1038 1039 1040
\ Destination mapping contains
\ addr u - range of virtal addresses
\ addr' - real start address
\ context - for exec regions, this is the job context

1041
User >code-flag
bernd's avatar
bernd committed
1042

bernd's avatar
bernd committed
1043
: alloc-data ( addr u -- u flag )
1044
    dup >r dest-size ! dest-vaddr 64! r>
bernd's avatar
bernd committed
1045
    dup alloc+guard dest-raddr !
bernd's avatar
bernd committed
1046
    c:key# alloz dest-ivsgen !
1047
    >code-flag @
1048
    IF
bernd's avatar
bernd committed
1049
	dup addr>replies  alloz dest-replies !