-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathkeys.fs
1543 lines (1294 loc) · 45.8 KB
/
keys.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 key storage
\ Copyright © 2013-2023 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/>.
require mkdir.fs
\ accept for password entry
scope{ config
Variable pw-level# 2 pw-level# ! \ pw-level# 0 is lowest
Variable pw-maxlevel# 4 pw-maxlevel# ! \ pw-maxlevel# is the maximum checked
}scope
\ Keys are passwords and private keys (self-keyed, i.e. private*public key)
cmd-buf0 uclass cmdbuf-o
maxdata -
key-salt# uvar keypack
keypack# uvar keypack-buf
key-cksum# uvar keypack-chksum
end-class cmd-keybuf-c
cmd-keybuf-c ' new static-a with-allocater code-key^ !
' code-key^ cmdbuf: code-key
code-key
cmd0lock 0 pthread_mutex_init drop
:is cmdbuf$ ( -- addr u ) keypack-buf cmdbuf# @ ;
:is maxstring ( -- n ) keypack# cmdbuf# @ - ;
code0-buf
:is alloc-code-bufs defers alloc-code-bufs
cmd-keybuf-c new code-key^ ! ;
:is free-code-bufs defers free-code-bufs
code-key^ @ .dispose ;
\ hashed key data base
Variable groups[] \ names of groups, sorted by order in groups file
User >storekey
Variable defaultkey
: free-key ( o:key -- o:key )
\g free all parts of the subkey
ke-sk sec-free
ke-sksig sec-free
ke-pk $free
ke-nick $free
ke-selfsig $free
ke-chat $free
ke-sigs[] $[]free
ke-pets[] $[]free
ke-pets# $free
ke-avatar $free ;
\ key class
0
enum key#anon
enum key#user
enum key#group
drop
\ key import type
0
enum import#self \ private key
enum import#manual \ manual import
enum import#scan \ scan import
enum import#chat \ seen in chat
enum import#dht \ dht import
enum import#invited \ invitation import
enum import#provisional \ provisional key
enum import#untrusted \ must be last
drop
$1F enum import#new \ new format
drop
Create imports$ $20 allot imports$ $20 bl fill
"Imscdipu" imports$ swap move
Variable import-type import#new import-type !
: >im-color# ( mask -- color# )
8 cells 0 DO dup 1 and IF drop I LEAVE THEN 2/ LOOP ;
theme-color: <self>
theme-color: <manual>
theme-color: <scan>
theme-color: <chat>
theme-color: <dht>
theme-color: <invited>
theme-color: <provisional>
theme-color: <untrusted>
current-theme
light-mode
$B600 to <self>
$D600 to <manual>
$9600 to <scan>
$C600 to <chat>
$A600 to <dht>
$8B01 to <invited>
$8C01 to <provisional>
$E600 to <untrusted>
dark-mode
$B601 to <self>
$D601 to <manual>
$9601 to <scan>
$C601 to <chat>
$A601 to <dht>
$8B00 to <invited>
$8C00 to <provisional>
$E600 to <untrusted>
to current-theme
Create >im-color ( xt n -- )
' <self> ,
' <manual> ,
' <scan> ,
' <chat> ,
' <dht> ,
' <invited> ,
' <provisional> ,
' <untrusted> ,
DOES> swap >im-color# 7 umin cells + [: perform execute ;] execute-theme-color ;
: .imports ( mask -- )
imports$ import#new bounds DO
dup 1 and IF
I c@ ['] emit 1 I imports$ [ lits, ] - lshift >im-color
THEN
2/ LOOP
drop ;
Create import-name$
"I myself" string,
"manual" string,
"scan" string,
"chat" string,
"dht" string,
"invited" string,
"provisional" string,
"untrusted" string,
: .import-colors ( -- )
import-name$
import#untrusted 1+ 0 ?DO
[: count 2dup type ;] 1 I lshift >im-color
space +
LOOP drop ;
\ sample key
key-entry ' new static-a with-allocater Constant sample-key
Variable key# \ key hash table
Variable nick# \ nick hash table
64Variable key-read-offset
: current-key ( addr u -- o )
2dup key| key# #@ drop
dup 0= IF drop ." unknown key: " 85type cr 0 EXIT THEN
cell+ >o ke-pk $! o o> ;
Variable sim-nick!
: nick! ( -- ) sim-nick! @ ?EXIT o { w^ optr }
ke-nick $@ nick# #@ d0= IF
optr cell ke-nick $@ nick# #! 0
ELSE
last# cell+ $@ bounds DO
ke-pk $@ I @ .ke-pk $@ str= IF
I @ .ke-nick# @ ke-nick# !
I @ .ke-offset 64@ ke-offset 64!
I @ .ke-sk sec@ dup IF ke-sk sec! ELSE 2drop THEN
I @ .ke-selfsig $@ IF
64@ ke-selfsig $@ IF
64@ 64u<
IF optr @ I ! THEN
ELSE drop 64drop THEN
ELSE drop THEN
UNLOOP EXIT
THEN
cell +LOOP
last# cell+ $@len cell/
optr cell last# cell+ $+!
THEN ke-nick# ! ;
: #.nick ( hash -- )
dup $@ type '#' emit cell+ $@len cell/ . ;
: last-pet@ ( -- addr u )
ke-pets[] $[]# ?dup-IF 1- ke-pets[] $[]@ ELSE #0. THEN ;
: pet! ( -- ) sim-nick! @ ?EXIT o { w^ optr }
last-pet@ nick# #@ d0= IF
optr cell last-pet@ nick# #! 0
ELSE
last# cell+ $@len cell/
optr cell last# cell+ $+!
THEN ke-pets[] $[]# 1- ke-pets# $[] ! ;
: key:new ( addr u -- o )
\G create new key, addr u is the public key
sample-key >o ke-sk ke-end over - erase
key-entry-table @ token-table !
>storekey @ ke-storekey !
2dup key| key# #@ d0= IF
key-read-offset
ELSE
last# cell+ $@ drop cell+ .ke-offset
THEN 64@ ke-offset 64!
1 import-type @ lshift [ 1 import#new lshift ]L or ke-imports !
keypack-all# n>64 key-read-offset 64+!
o cell- ke-end over - 2over key| key# #!
o>
current-key ;
0 Value last-key
: key?new ( addr u -- o )
\G Create or lookup new key
2dup key| key# #@ drop
dup 0= IF drop key:new
ELSE nip nip cell+ 1 import-type @ lshift over .ke-imports or! THEN
dup to last-key ;
\ search for keys - not optimized
: #split ( addr u -- addr u n )
[: 2dup '#' -scan nip >r
#0. 2over r@ 1+ /string >number
0= IF nip drop nip r> swap ELSE
rdrop drop 2drop 0 THEN ;] #10 base-execute ;
: nick-key ( addr u -- o / 0 ) \ search for key nickname
#split >r nick# #@ 2dup d0= IF rdrop drop EXIT THEN
r> cells safe/string 0= IF drop 0 EXIT THEN @ ;
: secret-keys# ( -- n )
0 key# [: cell+ $@ drop cell+ >o ke-sk @ 0<> - o> ;] #map ;
: secret-key ( n -- o/0 )
0 tuck key# [: cell+ $@ drop cell+ >o ke-sk @ IF
2dup = IF rot drop o -rot THEN 1+
THEN o> ;] #map 2drop ;
: .# ( n -- ) ?dup-IF '#' emit 0 .r THEN ;
: .nick-base ( o:key -- )
ke-nick $. ke-nick $@len 0= IF '#' emit ke-nick# @ 0 .r
ELSE ke-nick# @ .# THEN ;
: .pet-base ( o:key -- )
0 ke-pets[] [: space type dup ke-pets# $[] @ .# 1+ ;] $[]map drop ;
: .pet0-base ( o:key -- )
ke-pets[] $[]# IF 0 ke-pets[] $[]@ type 0 ke-pets# $[] @ .#
ELSE .nick-base THEN ;
: .real-nick ( o:key -- ) ['] .nick-base ke-imports @ >im-color ;
0 Value last-ki
: .nick ( o:key -- ) ['] .pet0-base ke-imports @ dup to last-ki >im-color ;
: .nick+pet ( o:key -- )
[: .nick-base .pet-base ;] ke-imports @ >im-color ;
: nick>pk ( nick u -- pk u )
nick-key ?dup-IF .ke-pk $@ ELSE 0 0 THEN ;
: host.nick>pk ( addr u -- pk u' )
'.' $split dup 0= IF 2swap THEN [: nick>pk type type ;] $tmp ;
: key-exist? ( addr u -- o/0 )
key# #@ IF cell+ THEN ;
\ permission modification
26 buffer: perm-chars
0 perm$ count bounds [DO] dup [I] c@ 'a' - perm-chars + c! 1+ [LOOP] drop
: .perm ( permission -- ) 1 perm$ count bounds DO
2dup and 0<> I c@ '-' rot select emit 2*
LOOP 2drop ;
: permand ( permand permor new -- permand' permor )
invert tuck and >r and r> ;
: >perm-mod ( permand permor -- permand' permor )
swap dup 0= IF drop dup invert THEN swap ;
: >perm ( addr u -- permand permor )
\G parse permissions: + adds, - removes permissions,
\G no modifier sets permissons.
0 0 ['] or { xt }
2swap bounds ?DO
I c@ case
'+' of >perm-mod ['] or to xt endof
'-' of >perm-mod ['] permand to xt endof
'=' of 2drop perm%default dup ['] or to xt endof
'a' - dup 'z' u<= IF
perm-chars + c@ 1 swap lshift xt execute
0 ( dummy for endcase )
THEN endcase
LOOP ;
: .permandor ( permand permor -- )
0 { +- }
1 perm$ count bounds DO >r
over r@ and 0= IF '-' dup +- <> IF dup to +- emit
ELSE drop THEN r> I c@ emit >r THEN
dup r@ and IF '+' dup +- <> IF dup to +- emit
ELSE drop THEN r> I c@ emit >r THEN
r> 2*
LOOP drop 2drop ;
\ read in permission groups, groups is in the .net2o directory
: >group-id ( addr u -- id/-1 )
-1 0 groups[] [: 2swap 2>r 2 cells /string
2over string-prefix? IF 2r> nip dup
ELSE 2r> THEN 1+ ;] $[]map
2nip drop ;
: >groups ( addr u pand por -- )
s" " groups[] $+[]!
[: { d^ pandor } pandor 2 cells type type ;]
groups[] dup $[]# 1- swap $[] $exec ;
: init-groups ( -- )
"myself" perm%myself dup >groups
"peer" perm%default dup >groups
"dht" perm%dhtroot dup >groups
"unknown" perm%unknown dup >groups
"blocked" perm%blocked perm%indirect or dup >groups ;
: .groups ( -- )
groups[] [: 2dup 2 cells /string type space
drop 2@ .permandor cr ;] $[]map ;
: .in-groups ( addr u -- )
bounds ?DO
I p@+ I - >r 64>n groups[] $[]@ 2 cells /string space type
r> +LOOP ;
: write-groups ( -- )
"groups" .net2o/ [: ['] .groups swap outfile-execute ;] new-file ;
: group-line ( -- )
parse-name parse-name >perm >groups ;
: read-groups-loop ( -- )
BEGIN refill WHILE group-line REPEAT ;
: read-groups ( -- )
"groups" .net2o-config/ 2dup file-status nip no-file# = IF
init-groups write-groups 2drop EXIT
THEN >included throw
['] read-groups-loop execute-parsing-named-file ;
: groups>mask ( addr u -- mask )
0 -rot bounds ?DO
I p@+ I - >r
64>n dup groups[] $[]# u>= !!no-group!!
groups[] $[]@ drop 2@ >r and r> or
r> +LOOP ;
: ?>groups ( mask -- mask' )
ke-groups $@len 0= IF
groups[] $[]# 0 DO
dup I groups[] $[]@ drop @
or over = IF
I ke-groups c$+!
I groups[] $[]@ drop cell+ @ invert and
THEN
LOOP
THEN drop ;
:is 'cold defers 'cold groups[] off read-groups ;
\ key display
[IFUNDEF] magenta brown constant magenta [THEN]
[IFDEF] gl-type : bg| >bg or ; [ELSE] : bg| drop ; [THEN]
Create 85colors-bw
0 , invers ,
invers , 0 ,
0 , invers ,
invers , 0 ,
Create 85colors-cl
yellow >fg blue >bg or bold or , red >fg white bg| ,
black >fg cyan bg| , green >fg black >bg or bold or ,
white >fg black >bg or bold or , magenta >fg yellow bg| ,
blue >fg yellow bg| , cyan >fg red >bg or bold or ,
[IFDEF] gl-type 85colors-cl [ELSE] 85colors-bw [THEN] Value 85colors
: .stripe85 ( addr u -- ) 0 -rot bounds ?DO
dup cells 85colors + @ attr! 1+
I 4 85type dup cells 85colors + @ attr! 1+
I 4 + 4 85type <default> cr 8 +LOOP drop ;
: .import85 ( addr u -- )
['] 85type ke-imports @ >im-color ;
: .rsk ( nick u -- )
skrev $20 .stripe85 space type ." (keep offline copy!)" cr ;
: .key ( addr u -- )
." nick: " .nick cr
." pubkey: " ke-pk $@ 85type cr
ke-sk @ IF
." seckey: " ke-sk sec@ .black85 ." (keep secret!)" cr THEN
ke-wallet @ IF
." wallet: " ke-wallet sec@ .black85 ." (keep secret!)" cr THEN
." valid: " ke-selfsig $@ .sigdates cr
." groups: " ke-groups $@ .in-groups cr
." perm: " ke-mask @ .perm cr ;
: .key-rest ( o:key -- o:key )
ke-pk $@ key| .import85
ke-sk @ IF ke-pwlevel @ 2 ['] .r #16 base-execute THEN
ke-wallet sec@ nip IF
wallet( space ke-wallet sec@ .black85 )else( ." W" )
ELSE wallet( $15 )else( 2 ) spaces THEN
ke-selfsig $@ space .sigdates
ke-avatar $@ dup IF space 85type ELSE 2drop THEN
ke-groups $@ 2dup .in-groups groups>mask invert
space ke-mask @ and -1 swap .permandor
#tab emit ke-imports @ .imports
space .nick+pet ;
: .key-list ( o:key -- o:key )
ke-imports @ [ 1 import#provisional lshift ]L and ?EXIT
ke-offset 64@ 64>d keypack-all# fm/mod nip 3 .r space
.key-rest cr ;
\ print invitations
: .key-invite ( o:key -- o:key )
ke-pk $@ keysize umin .import85
space .nick space ;
: .key-short ( o:key -- o:key )
ke-nick $. ke-prof $@len IF ." profile: " ke-prof $@ 85type THEN ;
\ print sorted list of keys by nick
Variable key-list[]
: $ins[]key ( o:key $array -- pos )
\G insert O(log(n)) into pre-sorted array
\G @var{pos} is the insertion offset or -1 if not inserted
{ a[] } 0 a[] $[]#
BEGIN 2dup u< WHILE 2dup + 2/ { left right $# }
ke-nick $@ $# a[] $[] @ .ke-nick $@ compare dup 0= IF
drop ke-nick# @ $# a[] $[] @ .ke-nick# @ - THEN
0< IF left $# ELSE $# 1+ right THEN
REPEAT drop >r
o { w^ ins$0 } ins$0 cell a[] r@ cells $ins r> ;
: keys>sort[] ( -- ) key-list[] $free
key# [: cell+ $@ drop cell+ >o key-list[] $ins[]key drop o> ;] #map ;
: list-keys ( -- )
keys>sort[]
." colors: " .import-colors cr
." num pubkey "
wallet( ." wallet " )
." date grp+prm h nick" cr
key-list[] $@ bounds ?DO I @ ..key-list cell +LOOP ;
: list-nicks ( -- )
nick# [: dup $. ." :" cr cell+ $@ bounds ?DO
I @ ..key-list cell +LOOP ;] #map ;
\ list of secret keys to select from
Variable secret-nicks[]
Variable secret-nicks#
: .secret-nicks-insert ( -- )
secret-nicks[] $free secret-nicks# $free
0 key# [: cell+ $@ drop cell+ >o ke-sk @ IF
secret-nicks[] $ins[]key >r
dup { c^ x } x 1 secret-nicks# r> $ins 1+
THEN o> ;] #map drop ;
: nick#>key# ( n1 -- n2 )
secret-nicks# $@ rot safe/string IF c@ ELSE drop -1 THEN ;
: .secret-nicks ( -- )
.secret-nicks-insert
secret-nicks[] $[]# 0 ?DO
I 1 ['] .r #36 base-execute space
I secret-nicks[] $[] @ ..key-rest cr
LOOP ;
\ dump keys
: dumpkey ( addr u -- ) drop cell+ >o
.\" x\" " ke-pk $@ 85type .\" \" key?new" cr
ke-sk @ IF .\" x\" " ke-sk @ keysize 85type .\" \" ke-sk sec! +seckey" cr THEN
'"' emit .nick .\" \" ke-nick $! "
ke-selfsig $@ drop 64@ 64>d [: '$' emit 0 ud.r ;] $10 base-execute
." . d>64 ke-first! " ke-type @ . ." ke-type !" cr o> ;
: .keys ( -- ) key# [: ." index: " dup $@ 85type cr cell+ $@
drop cell+ ..key ;] #map ;
: dumpkeys ( -- ) key# [: cell+ $@ dumpkey ;] #map ;
: key>o ( addrkey u1 -- o / 0 )
key| key# #@ 0= IF drop 0 EXIT THEN cell+ ;
: key>nick ( addrkey u1 -- nick u2 )
\G convert key to nick
key>o dup IF .ke-nick $@ ELSE 0 THEN ;
: key>key ( addrkey u1 -- key u2 )
\G expand key to full size and check if we know it
key>o dup IF .ke-pk $@ ELSE 0 THEN ;
: .key# ( addr u -- ) key|
." Key '" key# #@ 0= IF drop EXIT THEN
cell+ ..nick ." ' ok" cr ;
Forward dht-nick?
Forward addnick-owndht
Variable keysearchs#
hash: unknown-keys#
: .unkey-id ( addr u -- ) <err> 8 umin 85type ." (unknown)" <default>
[ 1 import#untrusted lshift ]L to last-ki ;
Variable dht-connection
: .key-id ( addr u -- ) last# >r key| 2dup key# #@ 0=
IF drop keysearchs# @ 1+ >r
2dup unknown-keys# #@ nip 0= dht-connection @ and IF
2dup $make [{: w^ key :}h1
key $@ dht-nick? key $free
1 keysearchs# +!@ drop ;] ?query-task send-event
?query-task event-block
BEGIN keysearchs# @ r@ - 0< WHILE query-task event-block REPEAT
rdrop 2dup key# #@ 0= IF drop
"<unknown>" 2over unknown-keys# #!
.unkey-id r> to last# EXIT THEN
ELSE rdrop .unkey-id r> to last# EXIT THEN
THEN
cell+ ..nick 2drop r> to last# ;
: .key-id? ( addr u -- ) last# >r key| 2dup key# #@ 0=
IF drop .unkey-id r> to last# EXIT THEN
cell+ ..nick 2drop r> to last# ;
: .con-id ( o:connection -- ) pubkey $@ .key-id ;
: .simple-id ( addr u -- ) last# >r
key>o dup IF ..nick-base ELSE drop ." unknown" THEN
r> to last# ;
: check-key ( addr u -- )
o IF pubkey @ IF
2dup pubkey $@ key| str= 0= IF
[: ." want: " pubkey $@ key| 85type cr
." got : " 2dup 85type cr ;] $err
true !!wrong-key!!
THEN
connect( .key# )else( 2drop ) EXIT
THEN THEN
2dup key-exist?
?dup-0=-IF perm%unknown ELSE .ke-mask @ THEN tmp-perm !
connect( 2dup .key# )
tmp-perm @ perm%blocked and IF
[: ." Unknown key, connection refused: " 85type cr ;] $err
true !!connect-perm!!
ELSE 2drop THEN ;
: search-key ( pkc -- o skc )
keysize key# #@ 0= !!unknown-key!!
cell+ dup .ke-sk sec@ 0= !!unknown-key!! ;
: search-key? ( pkc -- false / o skc )
keysize key# #@ 0= IF drop 0 EXIT THEN
cell+ dup .ke-sk sec@ 0= IF 2drop 0 EXIT THEN ;
\ apply permissions&groups
: apply-permission ( permand permor o:key -- permand permor o:key )
over ke-mask @ and over or ke-mask ! .key-list ;
: -group-perm ( o:key -- )
ke-groups $@ groups>mask invert ke-mask and! ;
: +group-perm ( o:key -- )
ke-groups $@ groups>mask ke-mask or! ;
: add-group ( id o:key -- )
dup -1 = !!no-group!! -group-perm u>64 cmdtmp$ ke-groups $+! +group-perm ;
: set-group ( id o:key -- )
dup -1 = !!no-group!! -group-perm u>64 cmdtmp$ ke-groups $! +group-perm ;
: sub-group ( id o:key -- )
dup -1 = !!no-group!! -group-perm u>64 cmdtmp$ ke-groups $@ 2over search
IF nip >r nip ke-groups dup $@len r> - rot $del
ELSE 2drop 2drop THEN +group-perm ;
: apply-group ( addr u o:key -- )
over c@ '+' = IF 1 /string >group-id add-group .key-list EXIT THEN
over c@ '-' = IF 1 /string >group-id sub-group .key-list EXIT THEN
>group-id set-group .key-list ;
\ calculate passphrase entropy
$100 cells buffer: ph-histogram
: >ph-histogram ( addr u -- )
\G generate a histogram of bytes in a string
ph-histogram $100 cells erase
bounds ?DO 1 I c@ cells ph-histogram + +! LOOP ;
: ph-sqsum ( addr u -- fsqsum )
\G compute the distance of neighboring letters relative to the used set
\G (i.e. only the populated slots count)
0e 1- 0 max bounds ?DO
0 I c@ I 1+ c@ 2dup min >r max r> ?DO
I cells ph-histogram + @ 0<> - LOOP
dup * [ 1e $10000 fm/ ] FLiteral fm* f+
LOOP ;
: g-test ( n -- entropy )
[ 1e $100 fm/ ] Fliteral fm* fln { f: n0 }
0e ph-histogram $100 cells bounds DO
I @ ?dup-IF s>f fdup fln n0 f- f* f+ THEN
cell +LOOP ;
: passphrase-entropy ( addr u -- fentropy )
\G estimate passphrase entropy
dup 0= IF 2drop 0e EXIT THEN 2dup
dup >r >ph-histogram
r@ g-test 1e-20 fmax 1/f r> fm*
ph-sqsum f* $100 fm* fsqrt ;
\ get passphrase
3 Value passphrase-retry#
$100 Constant max-passphrase# \ 256 characters should be enough...
max-passphrase# buffer: passphrase
: passphrase-in ( addr u -- addr u )
"PASSPHRASE" getenv 2dup d0= IF 2drop type
passphrase dup max-passphrase# accept* cr
ELSE 2nip THEN ;
: >passphrase ( addr u -- addr u )
\G create a 512 bit hash of the passphrase
no-key >c:key c:hash
keccak-padded c:key> keccak-padded keccak#max 2/ ;
: get-passphrase ( addr u -- addr u )
passphrase-in >passphrase ;
Variable keys
: lastkey@ ( -- addr u ) keys $[]# 1- keys sec[]@ ;
: key>default ( -- ) lastkey@ drop >storekey ! ;
: +key ( addr u -- ) keys sec+[]! ;
: +passphrase ( addr u -- ) get-passphrase +key ;
: +checkphrase ( addr u -- flag ) get-passphrase lastkey@ str= ;
: +newphrase ( -- )
BEGIN
input-color
s" Passphrase: " +passphrase
s" Retype pls: " +checkphrase 0= WHILE
cr error-color ." didn't match, try again please" cr
REPEAT cr default-color ;
: ">passphrase ( addr u -- ) >passphrase +key ;
: >seckey ( -- addr u )
ke-sk @ ke-pk $@ drop keypad ed-dh ;
: +seckey ( -- ) >seckey +key ;
\ "" ">passphrase \ following the encrypt-everything paradigm,
\ no password is the empty string! It's still encrypted ;-)!
\ a secret key just needs a nick and a type.
\ Secret keys can be persons and groups.
\ a public key needs more: nick, type, profile.
\ The profile is a structured document, i.e. pointed to by a hash.
\ a signature contains a pubkey, a checkbox bitmask,
\ a date, an expiration date, the signer's pubkey and the signature itself
\ (r+s). There is an optional signing protocol document (hash).
\ we store each item in a 256 bytes encrypted string, i.e. with a 16
\ byte salt and a 16 byte checksum.
: ke-last! ( 64date -- )
ke-selfsig $@len $10 umax ke-selfsig $!len
ke-selfsig $@ drop 64'+ 64! ;
: ke-first! ( 64date -- ) 64#-1 ke-last!
ke-selfsig $@ drop 64! ;
Variable save-keys-again
Variable key-version
: key-version$ "1" ;
key-version$ evaluate Constant key-version#
: new-pet? ( addr u -- addr u flag )
0 ke-pets[] [: rot >r 2over str= r> or ;] $[]map 0= ;
: ?sk ( addr u -- addr u )
over keypad sk>pk \ generate pubkey
keypad ke-pk $@ drop keysize tuck str= 0= !!wrong-key!! ;
scope{ net2o-base
cmd-table $@ inherit-table key-entry-table
\g
\g ### key storage commands ###
\g
$2 net2o: slit ( #lit -- ) \g deprecated slit version
p@ key-version @ 0= IF zz>n save-keys-again on ELSE 64invert THEN ;
$F net2o: kversion ( $:string -- ) \g key version
$> s>unumber? IF drop ELSE 2drop 0 THEN dup key-version !
key-version# u< save-keys-again or! ;
$11 net2o: privkey ( $:string -- )
\g private key
\ does not need to be signed, the secret key verifies itself
!!unsigned? $40 !!>=order?
keypack c@ $F and ke-pwlevel !
$> ?sk ke-sk sec! +seckey
"\0" ke-groups $! 0 groups[] $[]@ drop @ ke-mask ! ;
+net2o: keytype ( n -- ) !!signed? 1 !!>order? 64>n ke-type ! ;
\g key type (0: anon, 1: user, 2: group)
+net2o: keynick ( $:string -- ) !!signed? 2 !!>order? $> ke-nick $!
\g key nick
nick! ;
+net2o: keyprofile ( $:string -- ) !!signed? 4 !!>order? $> ke-prof $! ;
\g key profile (hash of a resource)
+net2o: keymask ( x -- ) !!unsigned? $40 !!>=order? 64>n
\g key access right mask
1 import-type @ lshift
[ 1 import#self lshift 1 import#new lshift or ]L
and 0= IF drop perm%default THEN dup ke-mask or! ?>groups ;
+net2o: keygroups ( $:groups -- ) !!unsigned? $20 !!>order? $>
\g access groups
1 import-type @ lshift
[ 1 import#self lshift 1 import#new lshift or ]L
and 0= IF 2drop "\x01" THEN
2dup ke-groups $! groups>mask ke-mask ! ;
+net2o: +keysig ( $:string -- ) !!unsigned? $10 !!>=order? $> ke-sigs[] $+[]! ;
\g add a key signature
+net2o: keyimport ( n -- ) !!unsigned? $10 !!>=order?
config:pw-level# @ 0< IF 64>n
dup [ 1 import#new lshift ]L and 0= IF
import#untrusted umin 1 swap lshift [ 1 import#new lshift ]L or
ELSE
[ 2 import#untrusted lshift 1- 1 import#new lshift or ]L and
THEN
ke-imports or!
ELSE 64drop THEN ;
+net2o: rskkey ( $:string --- )
\g revoke key, temporarily stored
\ does not need to be signed, the revoke key verifies itself
!!unsigned? $80 !!>=order?
$> 2dup skrev swap key| move ke-pk $@ drop check-rev? 0= !!not-my-revsk!!
pkrev keysize2 erase ke-rsk sec! ;
+net2o: keypet ( $:string -- ) !!unsigned? $>
new-pet? IF
ke-pets[] $+[]! pet! EXIT
THEN 2drop ;
+net2o: walletkey ( $:seed -- ) !!unsigned? $>
ke-wallet sec! ;
+net2o: avatar ( $:string -- )
\g key avatar profile (hash of a resource)
!!signed? 8 !!>order? $> ke-avatar $! ;
\ dummies that are retained even though we don't know what they are
+net2o: key-string1 ( $:string -- ) $> ke-[]1 $+[]! ;
+net2o: key-string2 ( $:string -- ) $> ke-[]2 $+[]! ;
+net2o: key-string3 ( $:string -- ) $> ke-[]3 $+[]! ;
+net2o: key-string4 ( $:string -- ) $> ke-[]4 $+[]! ;
+net2o: key-dhtsecs ( $:string -- )
\g persistent secrets for DHT roots, can not be changed regularly
$> ke-dhtsecs sec! ;
+net2o: key-sec2 ( $:string -- ) $> ke-sec2 sec! ;
+net2o: key-num1 ( 64n -- ) ke-#1 64! ;
+net2o: key-num2 ( 64n -- ) ke-#2 64! ;
+net2o: key-num3 ( 64n -- ) ke-#3 64! ;
+net2o: key-num4 ( 64n -- ) ke-#4 64! ;
}scope
key-entry-table $save
' context-table is gen-table
: key:nest-sig ( addr u -- addr u' flag )
no-ed-check? IF pk2-date? ELSE pk2-sig? THEN dup ?EXIT drop
2dup addnick-owndht
2dup + sigsize# - sigsize# >$
sigpk2size# - 2dup + keysize2 key?new n:>o $> ke-selfsig $!
sim-nick! off c-state off sig-ok ;
' key:nest-sig key-entry is nest-sig
key-entry-table @ sample-key .token-table !
: key:code ( -- )
code-key cmdlock lock
keypack keypack-all# erase
cmdreset init-reply also net2o-base ;
compsem: ['] key:code compile, also net2o-base ;
scope{ net2o-base
: end:key ( -- )
end-with previous cmdlock unlock ;
compsem: ['] end:key compile, previous ;
}scope
: key-crypt ( -- )
keypack keypack-all#
>storekey sec@ dup $20 u<= \ is a secret, no need to be slow
IF encrypt$ ELSE config:pw-level# @ encrypt-pw$ THEN ;
0 Value key-sfd \ secret keys
0 Value key-pfd \ pubkeys
\ legacy for early versions of net2o prior 20160606
: net2o>keys { addr u -- }
addr u .net2o/ addr u .keys/ rename-file drop ;
: ?legacy-keys ( flag -- )
\ !!FIXME!! needs to be removed when all current users
\ have migrated
IF
"pubkeys.k2o" net2o>keys
"seckeys.k2o" net2o>keys
THEN ;
: gen-keys-dir ( -- )
init-dirs ?.net2o/keys ?legacy-keys
groups[] $[]# 0= IF read-groups THEN ;
: ?fd-keys ( fd addr u -- fd' ) { addr u } dup ?EXIT drop
gen-keys-dir
addr u r/w open-file dup no-file# = IF
2drop addr u r/w create-file
THEN throw ;
: ?key-sfd ( -- fd )
key-sfd "seckeys.k2o" .keys/ ?fd-keys dup to key-sfd ;
: ?key-pfd ( -- fd )
key-pfd "pubkeys.k2o" .keys/ ?fd-keys dup to key-pfd ;
: key>sfile ( -- )
keypack keypack-all# ?key-sfd append-file ke-offset 64! ;
: key>pfile ( -- )
keypack keypack-all# ?key-pfd append-file ke-offset 64! ;
: key>sfile@pos ( 64pos -- ) 64dup 64#-1 64= IF 64drop key>sfile
ELSE 64>r keypack keypack-all# 64r> ?key-sfd write@pos-file THEN ;
: key>pfile@pos ( 64pos -- ) 64dup 64#-1 64= IF 64drop key>pfile
ELSE 64>r keypack keypack-all# 64r> ?key-pfd write@pos-file THEN ;
: rnd>sfile ( -- )
keypack keypack-all# >rng$ key>sfile ;
: rnd>pfile ( -- )
keypack keypack-all# >rng$ key>pfile ;
\ key generation
\ for reproducibility of the selfsig, always use the same order:
\ "pubkey" newkey <n> keytype "nick" keynick "sig" keyselfsig
User pk+sig$
keysize2 Constant pkrk#
: ]pk+sign ( addr u -- ) +cmdbuf ]sign ;
also net2o-base
: pack-core ( o:key -- ) \ core without key
ke-type @ ulit, keytype
ke-nick $@ $, keynick
ke-prof $@ dup IF $, keyprofile ELSE 2drop THEN
ke-avatar $@ dup IF $, avatar ELSE 2drop THEN ;
: pack-signkey ( o:key -- )
sign[
pack-core
ke-pk $@ +cmdbuf
ke-selfsig $@ +cmdbuf cmd-resolve> 2drop nestsig ;
: pack-corekey ( o:key -- )
pack-signkey
ke-imports @ ulit, keyimport
ke-mask @ ke-groups $@len IF
ke-groups $@ 2dup $, keygroups
groups>mask invert and THEN
?dup-IF ulit, keymask THEN
ke-pets[] [: $, keypet ;] $[]map
ke-storekey @ >storekey ! ;
: pack-coresec ( o:key -- )
ke-sk sec@ sec$, privkey
ke-rsk sec@ dup IF sec$, rskkey ELSE 2drop THEN
ke-wallet sec@ dup IF sec$, walletkey ELSE 2drop THEN ;
: pack-coreextra ( o:key -- )
ke-[]1 [: $, key-string1 ;] $[]map
ke-[]2 [: $, key-string2 ;] $[]map
ke-[]3 [: $, key-string3 ;] $[]map
ke-[]4 [: $, key-string4 ;] $[]map
ke-#1 64@ 64dup 64-0<> IF lit, key-num1 ELSE 64drop THEN
ke-#2 64@ 64dup 64-0<> IF lit, key-num2 ELSE 64drop THEN
ke-#3 64@ 64dup 64-0<> IF lit, key-num3 ELSE 64drop THEN
ke-#4 64@ 64dup 64-0<> IF lit, key-num4 ELSE 64drop THEN ;
: pack-secextra ( o:key -- )
ke-dhtsecs sec@ dup IF sec$, key-dhtsecs ELSE 2drop THEN
ke-sec2 sec@ dup IF sec$, key-sec2 ELSE 2drop THEN ;
previous
: pack-pubkey ( o:key -- )
key:code
key-version$ $, version
pack-corekey
pack-coreextra
end:key ;
: pack-outkey ( o:key -- )
key:code
"n2o" net2o-base:4cc,
key-version$ $, version
pack-signkey
end:key ;
: pack-seckey ( o:key -- )
key:code
key-version$ $, version
pack-corekey
pack-coresec
pack-coreextra
pack-secextra
end:key ;
: keynick$ ( o:key -- addr u )
\G get the annotations with signature
['] pack-core gen-cmd$ 2drop
ke-selfsig $@ tmp$ $+! tmp$ $@ ;
: keypk2nick$ ( o:key -- addr u )
\G get the annotations with signature
['] pack-core gen-cmd$ 2drop
ke-pk $@ tmp$ $+! ke-selfsig $@ tmp$ $+! tmp$ $@ ;
: mynick-key ( -- o )
pk@ key| key# #@ drop cell+ ;
: mynick$ ( -- addr u )
\G get my nick with signature
mynick-key .keynick$ ;
: mypk2nick$ ( o:key -- addr u )
\G get my nick with signature
mynick-key .keypk2nick$ ;
: key-sign ( o:key -- o:key )
['] pack-core gen-cmd$
[: type ke-pk $@ type ;] $tmp
now>never c:0key c:hash [: 0 ..sig ;] $tmp ke-selfsig $! ;
Variable cp-tmp
: sec-key? ( o:key -- flag )
ke-sk sec@ d0<>
ke-groups $@ $01 scan nip 0= and ;
: save-pubkeys ( -- )
key-pfd ?dup-IF close-file throw THEN
"pubkeys.k2o" .keys/ [: to key-pfd
key# [: cell+ $@ drop cell+ >o
sec-key? 0= IF pack-pubkey
flush( ." saving " .nick forth:cr )
key-crypt ke-offset 64@ key>pfile@pos
THEN o> ;] #map
0 to key-pfd ;] save-file ?key-pfd drop ;
: save-seckeys ( -- )
key-sfd ?dup-IF close-file throw THEN
"seckeys.k2o" .keys/ [: to key-sfd
key# [: cell+ $@ drop cell+ >o
sec-key? IF pack-seckey
config:pw-level# @ >r ke-pwlevel @ config:pw-level# !
key-crypt ke-offset 64@ key>sfile@pos
r> config:pw-level# !
THEN o> ;] #map
0 to key-sfd ;] save-file ?key-sfd drop ;
: save-keys ( -- ) ?.net2o/keys drop
save-pubkeys save-seckeys ;
\ respond to scanning keys
in net2o forward pklookup
true Value scan-once?
: scanned-key-in ( addr u -- )
." scanned " 2dup .key-id cr
key| key# #@ IF
cell+ >o [ 1 import#scan lshift ]L ke-imports or!