-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathnet2o.fs
2046 lines (1673 loc) · 59.1 KB
/
net2o.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
\ net2o protocol stack
\ Copyright © 2010-2024 Bernd Paysan
\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU Affero General Public License for more details.
\ You should have received a copy of the GNU Affero General Public License
\ along with this program. If not, see <http://www.gnu.org/licenses/>.
\ helper words
require version.fs
: n2o-greeting ( -- )
[: ." net2o " net2o-version type space (c) ." 2010-2025 Bernd Paysan" cr ;]
do-debug
is-color-terminal? IF +status ELSE -status THEN ;
require err.fs
\ required tools
require forward.fs
require mini-oof2.fs
require user-object.fs
require struct-val.fs
require rec-scope.fs
require unix/socket.fs
require unix/mmap.fs
require unix/pthread.fs
require unix/filestat.fs
require tools.fs
require debugging.fs
require kregion.fs
require crypto-api.fs
require keccak.fs
require threefish.fs
keccak-o crypto-o !
require rng.fs
require ed25519-donna.fs
require bdelta.fs
require minos2/jpeg-exif.fs
\ random initializer for hash
: hash-init-rng ( -- ) $10 rng$ hashinit swap move ;
hash-init-rng
\ crypto selection
: n/a' ( "name" -- xt )
['] ' catch IF ['] n/a THEN ;
Create crypt-modes
n/a' keccak-t ,
n/a' threefish-t ,
n/a' keyak-t ,
here crypt-modes - cell/ Constant crypts#
: >crypt ( n -- )
crypts# 1- umin cells crypt-modes + perform @ crypto-o ! c:init ;
0 >crypt
\ values, configurable
$4 Value max-size^2 \ 1k, don't fragment by default
$12 Value max-data# \ 16MB data space
$0C Value max-code# \ 256k code space
$10 Value max-block# \ 64k maximum block size+alignment
$0C Value min-block# \ 4k minimum block size
\ values, status
true Value connected?
\ constants, and depending values
$2A Constant overhead \ constant overhead
$40 Constant min-size
1 Value buffers#
min-size max-size^2 lshift Value maxdata ( -- n )
maxdata overhead + Value maxpacket
maxpacket $F + -$10 and #1216 umax Value maxpacket-aligned
max-size^2 6 + Value chunk-p2
$10 Constant key-salt#
$10 Constant key-cksum#
\ for bigger blocks, we use use alloc-mmap-guard, i.e. mmap with a
\ guard page after the end.
: alloc-buf ( -- addr )
maxpacket-aligned buffers# * alloc-mmap-guard ;
: alloc-buf+6 ( -- addr ) alloc-buf 6 + ;
: free-buf ( addr -- )
maxpacket-aligned buffers# * 2dup erase free+guard ;
: free-buf+6 ( addr -- )
6 - free-buf ;
[IFDEF] cygwin
: no-hybrid ; \ cygwin can't deal with hybrid stacks
[THEN]
\ per-thread memory space
UValue inbuf ( -- addr )
UValue tmpbuf ( -- addr )
UValue outbuf ( -- addr )
hash: routes#
\ add IP addresses
require classes.fs
require ip.fs
require socks.fs
UDefer other
: -other ['] noop is other ;
-other
Defer alloc-code-bufs ' noop is alloc-code-bufs
Defer free-code-bufs ' noop is free-code-bufs
Variable task-id#
: alloc-io ( -- ) \ allocate IO and reset generic user variables
io-buffers new io-mem !
1 task-id# +!@ task# !
-other
alloc-buf+6 to inbuf
alloc-buf to tmpbuf
alloc-buf+6 to outbuf
alloc-code-bufs
init-ed25519 c:init ;
:is thread-init ( -- ) defers thread-init
alloc-io b-out op-vector @ debug-vector ! ;
: free-io ( -- )
free-ed25519 c:free
free-code-bufs
0 io-mem !@ .dispose
inbuf free-buf+6
tmpbuf free-buf
outbuf free-buf+6 ;
alloc-io
Variable net2o-tasks
:is thread-init defers thread-init
rng-o off \ make sure no rng is active
;
: net2o-pass ( params xt n task -- )
dup net2o-tasks >stack pass debug-out debug-vector !
alloc-io prep-socks catch-loop
1+ ?dup-IF free-io 1- ?dup-IF ['] DoError do-debug THEN
ELSE ~~ bflush 0 (bye) ~~ THEN ;
: net2o-task ( params xt n -- task )
stacksize4 NewTask4 dup >r net2o-pass r> ;
Variable kills
: send-kill ( task -- )
up@ [{: task :}h1 [: -1 kills +! ;] task send-event 0 (bye) ;]
swap send-event ;
2 Constant kill-seconds#
kill-seconds# 1+ #1000000000 um* 2constant kill-timeout# \ 3s
#5000000. 2Constant kill-wait2# \ 5ms wait for threads to terminate
0 Value sender-task \ asynchronous sender thread (unused)
0 Value receiver-task \ receiver thread
0 Value timeout-task \ for handling timeouts
0 Value query-task \ for background queries initiated in other tasks
: net2o-kills ( -- )
true to terminating?
0 to sender-task
0 to receiver-task
0 to timeout-task
0 to query-task
net2o-tasks get-stack kills ! net2o-tasks $free
kills @ 0 ?DO
['] send-kill (kill)
LOOP ;
\ packet&header size
\ 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#
$00 Constant 16bit# \ protocol for very small networks
$10 Constant 64bit# \ standard, encrypted protocol
$0F Constant datasize#
Create header-sizes $06 c, $1a c, $FF c, $FF c,
Create tail-sizes $00 c, $10 c, $FF c, $FF c,
Create add-sizes $06 c, $2a c, $FF c, $FF c,
\ we don't know the header sizes of protocols 2 and 3 yet ;-)
: header-size ( addr -- n ) c@ headersize# and 4 rshift header-sizes + c@ ;
: tail-size ( addr -- n ) c@ headersize# and 4 rshift tail-sizes + c@ ;
: add-size ( addr -- n ) c@ headersize# and 4 rshift add-sizes + c@ ;
: body-size ( addr -- n ) min-size swap c@ datasize# and lshift ;
: packet-size ( addr -- n )
dup add-size swap body-size + ;
: packet-body ( addr -- addr )
dup header-size + ;
: packet-data ( addr -- addr u )
dup >r header-size r@ + r> body-size ;
add-sizes 1+ c@ min-size + Constant minpacket#
\ second byte constants
$80 Constant broadcasting# \ broadcast goes everywhere
$40 Constant multicasting# \ path is actually a group address
\ $30 Constant net2o-reserved# - should be 0
$08 Constant stateless# \ stateless message
$07 Constant acks#
$01 Constant ack-toggle#
$02 Constant b2b-toggle#
$04 Constant resend-toggle#
\ short packet information
: .header ( addr -- ) base @ >r hex
dup c@ >r
min-size r> datasize# and lshift h. ." bytes to "
net2o-header:mapaddr le-64@ u64. cr
r> base ! ;
\ each source has multiple destination spaces
64User dest-addr
User dest-flags
: >ret-addr ( -- )
inbuf net2o-header:dest return-addr reverse$16 ;
: >dest-addr ( -- )
inbuf net2o-header:mapaddr le-64@ dest-addr 64!
inbuf net2o-header:flags w@ dest-flags w! ;
\ validation stuff
User validated
$0001 Constant crypt-val
$0002 Constant own-crypt-val
$0004 Constant login-val
$0008 Constant cookie-val
$0010 Constant tmp-crypt-val
$0020 Constant signed-val
$0040 Constant newdata-val
$0080 Constant newcode-val
$0100 Constant keypair-val
$0200 Constant receive-val
$0400 Constant ivs-val
$0800 Constant qr-tmp-val
$1000 Constant enc-crypt-val
$2000 Constant ack-order-val
$4000 Constant wallet-val
$10 Constant validated#
: crypt? ( -- flag ) validated @ crypt-val and ;
: own-crypt? ( -- flag ) validated @ own-crypt-val and ;
: login? ( -- flag ) validated @ login-val and ;
: cookie? ( -- flag ) validated @ cookie-val and ;
: tmp-crypt? ( -- flag ) validated @ tmp-crypt-val and ;
: signed? ( -- flag ) validated @ signed-val and ;
: qr-crypt? ( -- flag ) validated @ qr-tmp-val and ;
: enc-crypt? ( -- flag ) validated @ enc-crypt-val and ;
: ack-order? ( -- flag ) validated @ ack-order-val and ;
: !!wallet? ( -- ) validated @ wallet-val and 0= !!wallet!! ;
: !!signed? ( -- ) signed? 0= !!unsigned!! ;
: !!unsigned? ( -- ) signed? !!signed!! ;
\ : reqmask ( -- addr )
\ task# @ reqmask[] $[] ;
\ events for context-oriented behavior
Defer do-connect
Defer do-disconnect
\ check for valid destination
$Variable dest-map s" " dest-map $!
:is 'image defers 'image
0 to inbuf 0 to outbuf 0 to tmpbuf io-mem off ;
:is 'cold defers 'cold false to terminating? keccak-o crypto-o !
hash-init-rng alloc-io ;
$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 + ;
scope{ mapc
: >data-head ( addr o:map -- flag ) dest-size 1- >r
dup dest-back r@ and u< IF r@ + 1+ THEN
dest-back r> invert and + \ add total offset
maxdata + \ add one packet size
dup addr dest-head umax!@ <> ;
: >linear ( addr -- addr' ) \ o:map
dup dest-back dest-size 1- and u< dest-size and +
dest-back dest-size negate and + ;
}scope
: dest-index ( -- addr ) dest-addr 64@ >dest-map ;
: check-dest ( size -- addr map o:job / f )
\G return false if invalid destination
\G return 1 if code, -1 if data, plus destination address
negate \ generate mask
dest-index 2 cells bounds ?DO
I @ IF
dup dest-addr 64@ I @ with mapc
dest-vaddr 64- 64>n and dup
dest-size u<
IF
dup addr>bits ack-bit# !
dest-raddr swap dup >data-head to ack-advance? +
o parent o> >o rdrop
UNLOOP rot drop EXIT THEN
drop endwith
THEN
cell +LOOP
drop false ;
\ context debugging
: .o ( -- ) context# ? ;
: o? ( -- ) ]] o 0= ?EXIT [[ ; immediate
\ Destination mapping contains
\ addr u - range of virtal addresses
\ addr' - real start address
\ context - for exec regions, this is the job context
User >code-flag
scope{ mapc
: alloc-data ( addr u -- u )
dup >r to dest-size to dest-vaddr r>
dup alloc-mmap-guard to dest-raddr
c:key# crypt-align + alloz to dest-ivsgen \ !!FIXME!! should be a kalloc
>code-flag @
IF
dup addr>replies alloc-mmap-guard to dest-replies
3 to dest-ivslastgen
ELSE
dup addr>ts alloz to dest-timestamps
THEN ;
}scope
: parent! ( o -- )
dup to parent ?dup-IF .my-key ELSE my-key-default THEN to my-key ;
: map-data ( addr u -- o )
o >code-flag @ IF mapc:rcode-class ELSE mapc:rdata-class THEN new
with mapc parent!
alloc-data
>code-flag @ 0= IF
dup addr>bytes allocate-bits data-ackbits !
THEN
drop
o endwith ;
: map-source ( addr u addrx -- o )
o >code-flag @ IF mapc:code-class ELSE mapc:data-class THEN new
with mapc parent!
alloc-data
>code-flag @ 0= IF
dup addr>ts allo1 data-resend# !
THEN
drop
o endwith ;
: map-data-dest ( vaddr u addr -- )
>r >r 64dup r> map-data r@ ! >dest-map r> @ swap ! ;
: map-code-dest ( vaddr u addr -- )
>r >r 64dup r> map-data r@ ! >dest-map cell+ r> @ swap ! ;
\ create context
8 Value bursts# \ number of
8 Value delta-damp# \ for clocks with a slight drift
bursts# 2* 2* 1- Value tick-init \ ticks without ack
#1000000 max-size^2 lshift Value bandwidth-init \ 32µs/burst=2MB/s
#2000 max-size^2 lshift Value bandwidth-max
64#-1 64Constant never
2 Value flybursts#
$100 Value flybursts-max#
$20 cells Value resend-size#
#50.000.000 d>64 64Constant init-delay# \ 50ms initial timeout step
#60.000.000.000 d>64 64Constant connect-timeout# \ 60s connect timeout
Variable init-context#
hash: msg-group# ( hash for group objects )
UValue msg-group-o
UValue connection
in net2o : new-log ( -- o )
log-table cmd-class new-tok ;
in net2o : new-ack ( -- o )
o ack-table ack-class new-tok >o parent!
init-delay# rtdelay 64!
flybursts# dup flybursts ! flyburst !
ticks lastack 64! \ asking for context creation is as good as an ack
bandwidth-init n>64 ns/burst 64!
never next-tick 64!
64#0 extra-ns 64!
max-int64 64-2/ min-slack 64!
max-int64 64-2/ 64negate max-slack 64!
o o> ;
: ack@ ( -- o )
ack-context @ ?dup-0=-IF net2o:new-ack dup ack-context ! THEN ;
scope{ net2o
: new-tmsg ( -- o )
o msg-table msg:class new-tok >o parent! o o> ;
: new-msging ( -- o )
o msging-class new >o parent! msging-table @ token-table ! o o> ;
defer new-msg ' new-tmsg is new-msg
}scope
: no-timeout ( -- ) max-int64 next-timeout 64!
ack-context @ ?dup-IF .timeouts off THEN ;
: -flow-control ['] noop is ack-xt ;
64User ticker
64User context-ticker 64#0 context-ticker 64!
: rtdelay! ( time -- )
timeouts @ IF \ don't update rtdelay if there were timeouts
rtdelay 64@ init-delay# 64<> IF 64drop EXIT THEN
THEN
recv-tick 64@ 64swap 64-
rtd( ." rtdelay: " 64dup 64>f .ns cr ) rtdelay 64! ;
User outflag outflag off
: set-flags ( -- )
0 outflag !@ outbuf net2o-header:tags c!
outbuf net2o-header:flags w@ dest-flags w! ;
: >send ( addr n -- )
\ over 0= IF 2drop rdrop EXIT THEN
dup >r [ 64bit# qos3# or ]L or outbuf c! set-flags
outbuf packet-body min-size r> lshift move ;
forward send-code-packet
: send-cX ( addr n -- ) +sendX2 >send send-code-packet ;
in net2o : new-context ( -- o )
context-class new >o timeout( ." new context: " o h. cr )
my-key-default to my-key \ set default key
o contexts !@ next-context !
o to connection \ current connection
context-table @ token-table ! \ copy pointer
init-context# @ context# ! 1 init-context# +!
return-addr return-address $10 move
['] no-timeout is timeout-xt ['] .iperr is setip-xt
['] noop is punch-done-xt ['] noop is sync-done-xt
['] noop is sync-none-xt ['] noop is ack-xt
['] send-cX is send0-xt
-flow-control
-1 blocksize !
1 blockalign !
config:timeouts# @ to max-timeouts
end-semas start-semas DO I 0 pthread_mutex_init drop
1 pthread-mutexes +LOOP
64#0 context-ticker 64!@ 64dup 64#0 64<> IF
ack@ >o ticker 64@ recv-tick 64! rtdelay! o> ELSE 64drop THEN
o o> ;
: ret-addr ( -- addr ) o IF return-address ELSE return-addr THEN ;
\ create new maps
Variable mapstart $1 mapstart !
: ret0 ( -- ) return-addr $10 erase ;
: setup! ( -- ) setup-table @ token-table ! ret0 ;
: wait-task-event ( xt -- )
wait-task @ main-up@ over select send-event ;
: context! ( -- )
context-table @ token-table !
o [{: connection :}h1 connection .do-connect ;]
wait-task-event ;
: new-code@ ( -- addrs addrd u -- )
new-code-s 64@ new-code-d 64@ new-code-size @ ;
: new-code! ( addrs addrd u -- )
new-code-size ! new-code-d 64! new-code-s 64! newcode-val validated or! ;
: new-data@ ( -- addrs addrd u -- )
new-data-s 64@ new-data-d 64@ new-data-size @ ;
: new-data! ( addrs addrd u -- )
new-data-size ! new-data-d 64! new-data-s 64! newdata-val validated or! ;
in net2o : new-map ( -- addr )
BEGIN
mapstart @ 1 mapstart +! reverse
[ cell 4 = ] [IF] 0 swap [ELSE] $FFFFFFFF00000000 and [THEN]
64dup >dest-map 2@ d0<> WHILE 64drop REPEAT ;
in net2o : new-data ( addrs addrd u -- )
dup max-data# u> !!mapsize!! min-size swap lshift
{ 64: addrs 64: addrd u -- }
o 0= IF
addrd >dest-map @ ?EXIT
net2o:new-context >o rdrop setup! THEN
msg( ." data map: " addrs x64. ." own: " addrd x64. u h. cr )
>code-flag off
addrd u addr data-rmap map-data-dest
addrs u map-source to data-map ;
in net2o : new-code ( addrs addrd u -- )
dup max-code# u> !!mapsize!! min-size swap lshift
{ 64: addrs 64: addrd u -- }
o 0= IF
addrd >dest-map @ ?EXIT
net2o:new-context >o rdrop setup! THEN
msg( ." code map: " addrs x64. ." own: " addrd x64. u h. cr )
$remote-host @ IF $remote-host $@ remote-host$ $! $remote-host $free THEN
>code-flag on
addrd u addr code-rmap map-code-dest
addrs u map-source to code-map ;
Forward new-ivs ( -- )
\G Init the new IVS
: create-maps ( -- ) validated @ >r
[ newcode-val newdata-val or invert ]L r@ and validated !
r@ newcode-val and IF new-code@ net2o:new-code ELSE rdrop EXIT THEN
r> newdata-val and IF new-data@ net2o:new-data THEN ;
: update-cdmap ( -- )
o 0= IF do-keypad sec@ nip keysize2 <> ?EXIT THEN
create-maps
o IF
validated @ keypair-val and IF
tmp-pubkey $@ pubkey $!
tmp-my-key @ to my-key
THEN
validated @ ivs-val and IF new-ivs THEN
tmp-perm @ ?dup-IF perm-mask ! tmp-perm off THEN
[ keypair-val ivs-val or invert ]L validated and!
THEN ;
\ dispose connection
scope{ mapc
: free-resend ( o:data ) dest-size addr>ts >r
data-resend# r@ ?free
addr dest-timestamps r> ?free ;
: free-resend' ( o:data ) dest-size addr>ts >r
addr dest-timestamps r> ?free ;
: free-code ( o:data -- ) dest-size >r
addr dest-raddr r@ ?free+guard
addr dest-ivsgen c:key# ?free
addr dest-replies r@ addr>replies ?free+guard
rdrop dispose ;
' free-code code-class is free-data
data-class :method free-data ( o:data -- )
free-resend free-code ;
: free-rcode ( o:data --- )
data-ackbits dest-size addr>bytes ?free
data-ackbits-buf $free
free-code ;
rdata-class :method free-data ( o:data -- )
free-resend' free-rcode ;
' free-rcode rcode-class is free-data
}scope
\ symmetric key management and searching in open connections
: search-context ( .. xt -- .. ) { xt }
\G xt has ( .. -- .. flag ) with true to continue
contexts BEGIN @ dup WHILE >o xt execute
next-context o> swap 0= UNTIL THEN drop ;
\ data sending around
: >blockalign ( n -- block )
blockalign @ naligned ;
: >maxalign ( n -- block )
maxdata naligned ;
: 64>blockalign ( 64 -- block )
blockalign @ dup >r 1- n>64 64+ r> negate n>64 64and ;
: /head ( u -- )
>blockalign dup negate residualread +!
data-map with mapc +to dest-head endwith ;
: max/head@ ( -- u )
data-map with mapc dest-head dup >maxalign dup to dest-head
swap - endwith ;
: /back ( u -- )
>blockalign dup negate residualwrite +!
data-rmap with mapc +to dest-back endwith ;
: max/back ( -- )
data-rmap with mapc dest-back >maxalign to dest-back endwith ;
: /tail ( u -- )
data-map >o +to mapc:dest-tail o> ;
: data-dest ( -- addr )
data-map with mapc
dest-vaddr dest-tail dest-size 1- and n>64 64+ endwith ;
\ new data sending around stuff, with front+back
scope{ mapc
: fix-range ( addr len1 -- addr len )
>r dest-size 1- and r> over + dest-size umin over - ;
: fix-size ( offset1 offset2 -- addr len )
over - >r dest-size 1- and r> over + dest-size umin over - ;
: fix-tssize ( offset1 offset2 -- addr len )
over - >r dest-size addr>ts 1- and r> over +
dest-size addr>ts umin over - ;
: fix-bitsize ( offset1 offset2 -- addr len )
over - >r dest-size addr>bits 1- and r> over +
dest-size addr>bits umin over - ;
: raddr+ ( addr len -- addr' len ) >r dest-raddr + r> ;
: fix-size' ( base offset1 offset2 -- addr len )
over - >r dest-size 1- and + r> ;
}scope
: head@ ( -- head ) data-map .mapc:dest-head ;
: data-head@ ( -- addr u )
\G you can read into this, it's a block at a time (wraparound!)
data-map with mapc
dest-head dest-back dest-size + fix-size raddr+ endwith
residualread @ umin ;
: rdata-back@ ( tail -- addr u )
\G you can write from this, also a block at a time
data-rmap with mapc
dest-back swap fix-size raddr+ endwith
residualwrite @ umin ;
: data-tail@ ( -- addr u )
\G you can send from this - as long as you stay block aligned
data-map with mapc
dest-raddr dest-tail dest-head fix-size' endwith ;
: data-head? ( -- flag )
\G return true if there is space to read data in
data-map with mapc dest-head dest-back dest-size + u< endwith ;
: data-tail? ( -- flag )
\G return true if there is data to send
data-map with mapc dest-tail dest-head u< endwith ;
: rdata-back? ( tail -- flag )
\G return true if there is data availabe to write out
data-rmap .mapc:dest-back u> ;
\ code sending around
: code-dest ( -- addr )
code-map with mapc dest-raddr dest-tail maxdata negate and + endwith ;
: code-vdest ( -- addr )
code-map with mapc dest-vaddr dest-tail n>64 64+ endwith ;
: code-reply ( -- addr )
code-map with mapc dest-tail addr>replies dest-replies + endwith ;
: send-reply ( -- addr )
code-map with mapc dest-addr 64@ dest-vaddr 64- 64>n addr>replies
dest-replies + endwith ;
: tag-addr ( -- addr )
code-rmap with mapc dest-addr 64@ dest-vaddr 64- 64>n addr>replies
dest-replies + endwith ;
reply buffer: dummy-reply
' noop dummy-reply reply-xt !
: reply[] ( index -- addr )
code-map with mapc
dup dest-size addr>bits u<
IF reply * dest-replies + ELSE dummy-reply THEN endwith ;
: reply-index ( -- index )
code-map .mapc:dest-tail addr>bits ;
: code+ ( n -- )
connection .code-map with mapc dup negate dest-tail and +
dest-size 1- and to dest-back endwith ;
: code-update ( n -- ) drop \ to be used later
connection .code-map with mapc dest-back to dest-tail endwith ;
\ aligned buffer to make encryption/decryption fast
: $>align ( addr u -- addr' u ) dup $400 u> ?EXIT
tuck aligned$ swap move aligned$ swap ;
\ timing records
Sema timing-sema
in net2o : track-timing ( -- ) \ initialize timing records
timing-stat $free ;
: )stats ]] THEN [[ ;
: stats( ]] timing-stat @ IF [[ ['] )stats assert-canary ; immediate
in net2o : timing$ ( -- addr u )
stats( timing-stat $@ EXIT ) ." no timing stats" cr s" " ;
in net2o : /timing ( n -- )
stats( timing-stat 0 rot $del ) ;
: .rec-timing ( addr u -- )
[: ack@ >o track-timing $@ \ do some dumps
bounds ?DO
I timestats:delta f>64 last-time 64+!
last-time 64@ 64>f 1n f* fdup f.
time-offset 64@ 64>f 1n f* 10e fmod f+ f.
\ I timestat:delta f.
I timestats:slack 1u f* f.
tick-init 1+ maxdata * 1k fm* fdup
I timestats:reqrate f/ f.
I timestats:rate f/ f.
I timestats:grow 1u f* f.
." timing" cr
timestats:sizeof +LOOP
track-timing $free o> ;] timing-sema c-section ;
in net2o : rec-timing ( addr u -- )
[: track-timing $+! ;] timing-sema c-section ;
\ flow control
: !ticks ( -- )
ticks ticker 64! ;
: ticks-init ( ticks -- )
64dup bandwidth-tick 64! next-tick 64! ;
: >rtdelay ( client serv -- client serv )
recv-tick 64@ 64dup lastack 64!
64over 64- rtd( ." rtdelay min to " 64dup 64>f .ns cr ) rtdelay 64min! ;
: timestat ( client serv -- )
64dup 64-0<= IF 64drop 64drop EXIT THEN
timing( 64over u64. 64dup u64. ." acktime" cr )
>rtdelay 64- 64dup lastslack 64!
lastdeltat 64@ delta-damp# 64rshift
64dup min-slack 64+! 64negate max-slack 64+!
64dup min-slack 64min!
max-slack 64max! ;
: b2b-timestat ( client serv -- )
64dup 64-0<= IF 64drop 64drop EXIT THEN
64- lastslack 64@ 64- slackgrow 64! ;
scope{ mapc
: >offset ( addr -- addr' flag )
dest-vaddr 64- 64>n dup dest-size u< ;
}scope
#5000000 Value rt-bias# \ 5ms additional flybursts allowed
in net2o : set-flyburst ( -- bursts )
rtdelay 64@ 64>f rt-bias# s>f f+ ns/burst 64@ 64>f f/ f>s
flybursts# +
bursts( dup . .o ." flybursts "
rtdelay 64@ u64. ns/burst 64@ u64. ." rtdelay" cr )
dup flybursts-max# min rate( ." flyburst: " dup . ) flyburst ! ;
in net2o : max-flyburst ( bursts -- ) flybursts-max# min flybursts max!@
bursts( 0= IF .o ." start bursts" cr THEN )else( drop ) ;
: >flyburst ( -- )
flyburst @ flybursts max!@ \ reset bursts in flight
0= IF recv-tick 64@ ticks-init
bursts( .o ." restart bursts " flybursts ? cr )
net2o:set-flyburst net2o:max-flyburst
THEN ;
: >timestamp ( time addr -- time' ts-array index / time' 0 0 )
>flyburst
64>r time-offset 64@ 64+ 64r>
parent .data-map dup 0= IF drop 0 0 EXIT THEN dup
>r with mapc >offset IF
dest-tail dest-size endwith >r over - r> 1- and
addr>bits 1 max window-size !
addr>ts r> .mapc:dest-timestamps swap
ELSE o> rdrop 0 0 THEN ;
in net2o : ack-addrtime ( ticks addr -- )
>timestamp over IF
dup tick-init 1+ 64s u>
IF + dup >r 64@
r@ tick-init 1+ 64s - 64@
64dup 64-0<= >r 64over 64-0<= r> or
IF 64drop 64drop ELSE 64- lastdeltat 64! THEN r>
ELSE + THEN
64@ timestat
ELSE 2drop 64drop THEN ;
in net2o : ack-b2btime ( ticks addr -- )
>timestamp over IF + 64@ b2b-timestat
ELSE 2drop 64drop THEN ;
\ set rate calculation
#20000000 Value slack-default# \ 20ms slack leads to backdrop of factor 2
#1000000 Value slack-bias# \ 1ms without effect
slack-default# 2* 2* n>64 64Constant slack-ignore# \ above 80ms is ignored
#0 Value slack-min# \ minimum effect limit
3 4 2Constant ext-damp# \ 75% damping
5 2 2Constant delta-t-grow# \ 4 times delta-t
: slack-max# ( -- n ) max-slack 64@ min-slack 64@ 64- ;
: slack# ( -- n ) slack-max# 64>n 2/ 2/ slack-default# max ;
: >slack-exp ( -- rfactor )
lastslack 64@ min-slack 64@ 64-
64dup 64abs slack-ignore# 64u> IF
msg( ." slack ignored: " 64dup u64. cr )
64drop 64#0 lastslack 64@ min-slack 64!
THEN
64>n stats( dup s>f stat-tuple to timestats:slack )
slack-bias# - slack-min# max slack# 2* 2* min
s>f slack# fm/ 2e fswap f** ;
: aggressivity-rate ( slack -- slack' )
slack-max# 64-2/ 64>n slack-default# tuck min swap 64*/ ;
: slackext ( rfactor -- slack )
slackgrow 64@
window-size @ tick-init 1+ bursts# - 2* 64*/
64>f f* f>64
slackgrow' 64@ 64+ 64dup ext-damp# 64*/ slackgrow' 64!
64#0 64max aggressivity-rate ;
: rate-limit ( rate -- rate' )
\ not too quickly go faster!
64dup last-ns/burst 64!@ 64max ;
: >extra-ns ( rate -- rate' )
>slack-exp fdup 64>f f* f>64 slackext
64over 64-2* 64-2* 64min \ limit to 4* rate
64dup extra-ns 64! 64+ ;
: stat+ ( addr -- ) stat-tuple timestats:sizeof timing-stat $+! ;
: rate-stat1 ( rate deltat -- rate deltat )
recv-tick 64@ time-offset 64@ 64-
64dup last-time 64!@ 64- 64>f stat-tuple to timestats:delta
64over 64>f stat-tuple to timestats:reqrate ;
: rate-stat2 ( rate -- rate )
64dup extra-ns 64@ 64+ 64>f stat-tuple to timestats:rate
slackgrow 64@ 64>f stat-tuple to timestats:grow
stat+ ;
in net2o : set-rate ( rate deltat -- )
rate( ." r/d: " 64over u64. 64dup u64. )
stats( rate-stat1 )
64>r tick-init 1+ validated @ validated# rshift 1 max 64*/
64dup >extra-ns noens( 64drop )else( 64nip )
64r> delta-t-grow# 64*/ 64min ( no more than 2*deltat )
bandwidth-max n>64 64max
rate-limit stats( rate-stat2 ) rate( ." rate: " 64dup u64. )
ns/burst 64!@ bandwidth-init n>64 64= IF \ first acknowledge
net2o:set-flyburst
net2o:max-flyburst
THEN rate( cr ) ;
\ acknowledge
$20 Value mask-bits#
: >mask0 ( addr mask -- addr' mask' )
BEGIN dup 1 and 0= WHILE 1 rshift maxdata under+ dup 0= UNTIL THEN ;
: >legit-back ( addr mask -- addr' mask' )
data-map .mapc:dest-back >r
over r@ [ maxdata $20 * ]L umax [ maxdata $20 * ]L - u<
IF r> 2drop 0 EXIT THEN
over r@ u< IF r@ rot - addr>bits rshift r> swap EXIT THEN
rdrop ;
: >legit-head ( addr mask -- addr' mask' )
data-map .mapc:dest-head >r
over r@ u>=
IF r> 2drop 0 EXIT THEN
over [ maxdata $20 * ]L + r@ u>
IF over [ maxdata $20 * ]L + r> - addr>bits -1 swap lshift
invert and EXIT THEN
rdrop ;
in net2o : resend-mask ( addr mask -- )
>legit-back >legit-head dup 0= IF 2drop EXIT THEN
>mask0
resend( ." mask: " hex[ >r dup u. r> dup u. ]hex cr )
data-resend $@ bounds ?DO
over I cell+ @ swap dup maxdata mask-bits# * + within IF
over I 2@ rot >r
BEGIN over r@ u> WHILE 2* >r maxdata - r> REPEAT
rdrop nip or >mask0
resend( I 2@ hex[ ." replace: " swap . . ." -> "
>r dup u. r> dup u. cr ]hex )
I 2! UNLOOP EXIT
THEN
2 cells +LOOP { d^ mask+ } mask+ 2 cells data-resend $+! ;
in net2o : ack-resend ( flag -- ) resend-toggle# and to ack-resend~ ;
: resend$@ ( -- addr u )
data-resend $@ IF
2@ >mask0 1 and IF maxdata ELSE 0 THEN
swap data-map >o mapc:dest-size 1- and mapc:dest-raddr + o> swap
ELSE drop 0 0 THEN ;
: resend? ( -- flag )
data-resend $@ IF
2@ 0<> swap data-map .mapc:dest-head u< and
ELSE drop false THEN ;
: resend-dest ( -- addr )
data-resend $@ drop cell+ @
data-map with mapc dest-size 1- and n>64 dest-vaddr 64+ endwith ;
: /resend ( u -- )
0 +DO
data-resend $@ drop
dup >r 2@ -2 and >mask0 tuck r> 2!
0= IF data-resend 0 2 cells $del THEN
maxdata +LOOP ;
: data-resend-flush ( -- )
data-resend $@len 0 U+DO
data-resend $@ I /string drop @ 0= IF
data-resend I 2 cells $del
0 data-resend $@len I replace-loop
ELSE
[ 2 cells ]L
THEN
+LOOP ;
: remove-resend { nback -- }
data-resend $@ bounds U+DO
I cell+ @ nback [ maxdata $20 * ]L umax [ maxdata $20 * ]L -
u< IF I off
ELSE I cell+ @ nback u< IF
nback dup I cell+ !@ -
addr>bits I @ swap rshift I !
THEN
THEN
[ 2 cells ]L +LOOP
data-resend-flush ;
: rewind-resend ( oback nback o:map -- )
parent .remove-resend drop ;
\ resend third handshake
: push-reply ( addr u -- ) resend0 $! return-addr r0-address $10 move ;
\ load crypto here
require crypt.fs
\ file handling
require file.fs
\ helpers for addresses
Forward >sockaddr
Forward sockaddr+return
: -sig ( addr u -- addr u' ) 2dup + 1- c@ 2* $11 + - ;