Artifact
9c5982b60604e2721a1c0e08c75235568eb1cac1
File
net2o-keys.fs
— part of check-in
[8c1e9a6b6d]
at
2013-03-03 01:48:50
on branch trunk
— Changed compile> to comp: and friends
(user:
bernd
size: 5093)
0000: 5c 20 6b 65 79 20 68 61 6e 64 6c 69 6e 67 0a 0a \ key handling..
0010: 72 65 71 75 69 72 65 20 6d 6b 64 69 72 2e 66 73 require mkdir.fs
0020: 0a 0a 5c 20 68 61 73 68 65 64 20 6b 65 79 20 64 ..\ hashed key d
0030: 61 74 61 20 62 61 73 65 0a 0a 6f 62 6a 65 63 74 ata base..object
0040: 20 63 6c 61 73 73 0a 66 69 65 6c 64 3a 20 6b 65 class.field: ke
0050: 2d 73 6b 0a 66 69 65 6c 64 3a 20 6b 65 2d 6e 69 -sk.field: ke-ni
0060: 63 6b 0a 66 69 65 6c 64 3a 20 6b 65 2d 6e 61 6d ck.field: ke-nam
0070: 65 0a 66 69 65 6c 64 3a 20 6b 65 2d 73 69 67 73 e.field: ke-sigs
0080: 0a 36 34 66 69 65 6c 64 3a 20 6b 65 2d 63 72 65 .64field: ke-cre
0090: 61 74 65 64 0a 36 34 66 69 65 6c 64 3a 20 6b 65 ated.64field: ke
00a0: 2d 65 78 70 69 72 65 73 0a 65 6e 64 2d 63 6c 61 -expires.end-cla
00b0: 73 73 20 6b 65 79 2d 65 6e 74 72 79 0a 0a 6b 65 ss key-entry..ke
00c0: 79 2d 65 6e 74 72 79 20 40 20 62 75 66 66 65 72 y-entry @ buffer
00d0: 3a 20 73 61 6d 70 6c 65 2d 6b 65 79 0a 0a 56 61 : sample-key..Va
00e0: 72 69 61 62 6c 65 20 6b 65 79 2d 74 61 62 6c 65 riable key-table
00f0: 0a 56 61 72 69 61 62 6c 65 20 74 68 69 73 2d 6b .Variable this-k
0100: 65 79 0a 56 61 72 69 61 62 6c 65 20 74 68 69 73 ey.Variable this
0110: 2d 6b 65 79 69 64 0a 73 61 6d 70 6c 65 2d 6b 65 -keyid.sample-ke
0120: 79 20 74 68 69 73 2d 6b 65 79 20 21 20 5c 20 64 y this-key ! \ d
0130: 75 6d 6d 79 0a 0a 3a 20 63 75 72 72 65 6e 74 2d ummy..: current-
0140: 6b 65 79 20 28 20 61 64 64 72 20 75 20 2d 2d 20 key ( addr u --
0150: 29 0a 20 20 20 20 6b 65 79 2d 74 61 62 6c 65 20 ). key-table
0160: 23 40 20 64 72 6f 70 20 64 75 70 20 74 68 69 73 #@ drop dup this
0170: 2d 6b 65 79 20 21 20 3e 6f 20 72 64 72 6f 70 20 -key ! >o rdrop
0180: 3b 0a 3a 20 6d 61 6b 65 2d 74 68 69 73 6b 65 79 ;.: make-thiskey
0190: 20 28 20 61 64 64 72 20 2d 2d 20 29 0a 20 20 20 ( addr -- ).
01a0: 20 64 75 70 20 24 40 20 64 72 6f 70 20 74 68 69 dup $@ drop thi
01b0: 73 2d 6b 65 79 69 64 20 21 20 20 63 65 6c 6c 2b s-keyid ! cell+
01c0: 20 24 40 20 64 72 6f 70 20 64 75 70 20 74 68 69 $@ drop dup thi
01d0: 73 2d 6b 65 79 20 21 20 3e 6f 20 72 64 72 6f 70 s-key ! >o rdrop
01e0: 20 3b 0a 0a 3a 20 6e 65 77 2d 6b 65 79 20 28 20 ;..: new-key (
01f0: 61 64 64 72 20 75 20 2d 2d 20 29 0a 20 20 20 20 addr u -- ).
0200: 5c 20 61 64 64 72 20 75 20 69 73 20 74 68 65 20 \ addr u is the
0210: 70 75 62 6c 69 63 20 6b 65 79 0a 20 20 20 20 73 public key. s
0220: 61 6d 70 6c 65 2d 6b 65 79 20 6b 65 79 2d 65 6e ample-key key-en
0230: 74 72 79 20 40 20 32 64 75 70 20 65 72 61 73 65 try @ 2dup erase
0240: 0a 20 20 20 20 32 6f 76 65 72 20 6b 65 79 2d 74 . 2over key-t
0250: 61 62 6c 65 20 23 21 20 63 75 72 72 65 6e 74 2d able #! current-
0260: 6b 65 79 20 3b 0a 0a 3a 20 28 64 69 67 69 74 73 key ;..: (digits
0270: 3e 24 29 20 28 20 61 64 64 72 20 75 20 2d 2d 20 >$) ( addr u --
0280: 61 64 64 72 27 20 75 27 20 29 20 73 61 76 65 2d addr' u' ) save-
0290: 6d 65 6d 0a 20 20 20 20 3e 72 20 64 75 70 20 64 mem. >r dup d
02a0: 75 70 20 72 3e 20 62 6f 75 6e 64 73 20 3f 44 4f up r> bounds ?DO
02b0: 0a 09 49 20 32 20 73 3e 6e 75 6d 62 65 72 20 64 ..I 2 s>number d
02c0: 72 6f 70 20 6f 76 65 72 20 63 21 20 63 68 61 72 rop over c! char
02d0: 2b 20 0a 20 20 20 20 32 20 2b 4c 4f 4f 50 20 20 + . 2 +LOOP
02e0: 6f 76 65 72 20 2d 20 3b 0a 0a 3a 20 68 65 78 3e over - ;..: hex>
02f0: 24 20 28 20 61 64 64 72 20 75 20 2d 2d 20 61 64 $ ( addr u -- ad
0300: 64 72 27 20 75 27 20 29 0a 20 20 20 20 5b 27 5d dr' u' ). [']
0310: 20 28 64 69 67 69 74 73 3e 24 29 20 24 31 30 20 (digits>$) $10
0320: 62 61 73 65 2d 65 78 65 63 75 74 65 20 3b 0a 0a base-execute ;..
0330: 3a 20 78 22 20 28 20 22 68 65 78 73 74 72 69 6e : x" ( "hexstrin
0340: 67 22 20 2d 2d 20 61 64 64 72 20 75 20 29 0a 20 g" -- addr u ).
0350: 20 20 20 27 22 27 20 70 61 72 73 65 20 68 65 78 '"' parse hex
0360: 3e 24 20 3b 0a 63 6f 6d 70 3a 20 65 78 65 63 75 >$ ;.comp: execu
0370: 74 65 20 70 6f 73 74 70 6f 6e 65 20 53 4c 69 74 te postpone SLit
0380: 65 72 61 6c 20 3b 0a 0a 56 6f 63 61 62 75 6c 61 eral ;..Vocabula
0390: 72 79 20 6b 65 79 2d 70 61 72 73 65 72 0a 0a 3a ry key-parser..:
03a0: 20 5e 6b 65 79 20 28 20 2d 2d 20 66 73 74 61 72 ^key ( -- fstar
03b0: 74 20 29 20 20 74 68 69 73 2d 6b 65 79 20 40 20 t ) this-key @
03c0: 3b 0a 0a 61 6c 73 6f 20 6b 65 79 2d 70 61 72 73 ;..also key-pars
03d0: 65 72 20 64 65 66 69 6e 69 74 69 6f 6e 73 0a 0a er definitions..
03e0: 3a 20 69 64 3a 20 28 20 22 69 64 22 20 2d 2d 20 : id: ( "id" --
03f0: 29 20 30 20 70 61 72 73 65 20 68 65 78 3e 24 20 ) 0 parse hex>$
0400: 6e 65 77 2d 6b 65 79 20 3b 0a 3a 20 73 6b 3a 20 new-key ;.: sk:
0410: 28 20 22 73 6b 22 20 2d 2d 20 29 20 30 20 70 61 ( "sk" -- ) 0 pa
0420: 72 73 65 20 68 65 78 3e 24 20 6b 65 2d 73 6b 20 rse hex>$ ke-sk
0430: 24 21 20 3b 0a 3a 20 6e 69 63 6b 3a 20 28 20 22 $! ;.: nick: ( "
0440: 73 6b 22 20 2d 2d 20 29 20 30 20 70 61 72 73 65 sk" -- ) 0 parse
0450: 20 6b 65 2d 6e 69 63 6b 20 24 21 20 3b 0a 3a 20 ke-nick $! ;.:
0460: 6e 61 6d 65 3a 20 28 20 22 73 6b 22 20 2d 2d 20 name: ( "sk" --
0470: 29 20 30 20 70 61 72 73 65 20 6b 65 2d 6e 61 6d ) 0 parse ke-nam
0480: 65 20 24 21 20 3b 0a 3a 20 63 72 65 61 74 65 64 e $! ;.: created
0490: 3a 20 28 20 22 6e 75 6d 62 65 72 22 20 2d 2d 20 : ( "number" --
04a0: 29 20 20 70 61 72 73 65 2d 6e 61 6d 65 20 73 3e ) parse-name s>
04b0: 6e 75 6d 62 65 72 20 64 3e 36 34 20 6b 65 2d 63 number d>64 ke-c
04c0: 72 65 61 74 65 64 20 36 34 21 20 3b 0a 3a 20 65 reated 64! ;.: e
04d0: 78 70 69 72 65 73 3a 20 28 20 22 6e 75 6d 62 65 xpires: ( "numbe
04e0: 72 22 20 2d 2d 20 29 20 20 70 61 72 73 65 2d 6e r" -- ) parse-n
04f0: 61 6d 65 20 73 3e 6e 75 6d 62 65 72 20 64 3e 36 ame s>number d>6
0500: 34 20 6b 65 2d 65 78 70 69 72 65 73 20 36 34 21 4 ke-expires 64!
0510: 20 3b 0a 0a 70 72 65 76 69 6f 75 73 20 64 65 66 ;..previous def
0520: 69 6e 69 74 69 6f 6e 73 0a 0a 3a 20 2e 6b 65 79 initions..: .key
0530: 20 28 20 61 64 64 72 20 2d 2d 20 29 20 20 64 75 ( addr -- ) du
0540: 70 20 40 20 30 3d 20 49 46 20 20 64 72 6f 70 20 p @ 0= IF drop
0550: 20 45 58 49 54 20 20 54 48 45 4e 0a 20 20 20 20 EXIT THEN.
0560: 2e 22 20 69 64 3a 20 22 20 20 20 64 75 70 20 24 ." id: " dup $
0570: 40 20 78 74 79 70 65 20 63 72 20 63 65 6c 6c 2b @ xtype cr cell+
0580: 20 24 40 20 64 72 6f 70 20 3e 6f 0a 20 20 20 20 $@ drop >o.
0590: 6b 65 2d 73 6b 20 20 20 40 20 49 46 20 20 2e 22 ke-sk @ IF ."
05a0: 20 73 6b 3a 20 22 20 20 20 6b 65 2d 73 6b 20 24 sk: " ke-sk $
05b0: 40 20 78 74 79 70 65 20 63 72 20 20 54 48 45 4e @ xtype cr THEN
05c0: 0a 20 20 20 20 6b 65 2d 6e 69 63 6b 20 40 20 49 . ke-nick @ I
05d0: 46 20 20 2e 22 20 6e 69 63 6b 3a 20 22 20 6b 65 F ." nick: " ke
05e0: 2d 6e 69 63 6b 20 24 40 20 74 79 70 65 20 63 72 -nick $@ type cr
05f0: 20 20 54 48 45 4e 0a 20 20 20 20 6b 65 2d 6e 61 THEN. ke-na
0600: 6d 65 20 40 20 49 46 20 20 2e 22 20 6e 61 6d 65 me @ IF ." name
0610: 3a 20 22 20 6b 65 2d 6e 61 6d 65 20 24 40 20 74 : " ke-name $@ t
0620: 79 70 65 20 63 72 20 20 54 48 45 4e 0a 20 20 20 ype cr THEN.
0630: 20 6b 65 2d 63 72 65 61 74 65 64 20 36 34 40 20 ke-created 64@
0640: 36 34 64 75 70 20 36 34 2d 30 3d 20 49 46 20 20 64dup 64-0= IF
0650: 36 34 64 72 6f 70 0a 20 20 20 20 45 4c 53 45 20 64drop. ELSE
0660: 20 2e 22 20 63 72 65 61 74 65 64 3a 20 22 20 36 ." created: " 6
0670: 34 3e 64 20 64 2e 20 63 72 20 20 54 48 45 4e 0a 4>d d. cr THEN.
0680: 20 20 20 20 6b 65 2d 65 78 70 69 72 65 73 20 36 ke-expires 6
0690: 34 40 20 36 34 64 75 70 20 36 34 2d 30 3d 20 49 4@ 64dup 64-0= I
06a0: 46 20 20 36 34 64 72 6f 70 0a 20 20 20 20 45 4c F 64drop. EL
06b0: 53 45 20 20 2e 22 20 65 78 70 69 72 65 73 3a 20 SE ." expires:
06c0: 22 20 36 34 3e 64 20 64 2e 20 63 72 20 20 54 48 " 64>d d. cr TH
06d0: 45 4e 0a 20 20 20 20 6f 3e 20 63 72 20 3b 0a 0a EN. o> cr ;..
06e0: 3a 20 2e 73 6b 65 79 20 28 20 61 64 64 72 20 2d : .skey ( addr -
06f0: 2d 20 29 20 20 64 75 70 20 63 65 6c 6c 2b 20 24 - ) dup cell+ $
0700: 40 20 64 72 6f 70 20 40 20 20 20 20 49 46 20 20 @ drop @ IF
0710: 2e 6b 65 79 20 20 45 4c 53 45 20 20 64 72 6f 70 .key ELSE drop
0720: 20 20 54 48 45 4e 20 3b 0a 3a 20 2e 70 6b 65 79 THEN ;.: .pkey
0730: 20 28 20 61 64 64 72 20 2d 2d 20 29 20 20 64 75 ( addr -- ) du
0740: 70 20 63 65 6c 6c 2b 20 24 40 20 64 72 6f 70 20 p cell+ $@ drop
0750: 40 20 30 3d 20 49 46 20 20 2e 6b 65 79 20 20 45 @ 0= IF .key E
0760: 4c 53 45 20 20 64 72 6f 70 20 20 54 48 45 4e 20 LSE drop THEN
0770: 3b 0a 0a 3a 20 64 75 6d 70 2d 73 6b 65 79 73 20 ;..: dump-skeys
0780: 28 20 66 64 20 2d 2d 20 29 0a 20 20 20 20 5b 3a ( fd -- ). [:
0790: 20 6b 65 79 2d 74 61 62 6c 65 20 5b 27 5d 20 2e key-table ['] .
07a0: 73 6b 65 79 20 23 6d 61 70 20 3b 5d 20 73 77 61 skey #map ;] swa
07b0: 70 20 6f 75 74 66 69 6c 65 2d 65 78 65 63 75 74 p outfile-execut
07c0: 65 20 3b 0a 3a 20 64 75 6d 70 2d 70 6b 65 79 73 e ;.: dump-pkeys
07d0: 20 28 20 66 64 20 2d 2d 20 29 0a 20 20 20 20 5b ( fd -- ). [
07e0: 3a 20 6b 65 79 2d 74 61 62 6c 65 20 5b 27 5d 20 : key-table [']
07f0: 2e 70 6b 65 79 20 23 6d 61 70 20 3b 5d 20 73 77 .pkey #map ;] sw
0800: 61 70 20 6f 75 74 66 69 6c 65 2d 65 78 65 63 75 ap outfile-execu
0810: 74 65 20 3b 0a 0a 3a 20 3f 2e 6e 65 74 32 6f 20 te ;..: ?.net2o
0820: 28 20 2d 2d 20 29 0a 20 20 20 20 73 22 20 7e 2f ( -- ). s" ~/
0830: 2e 6e 65 74 32 6f 22 20 72 2f 6f 20 6f 70 65 6e .net2o" r/o open
0840: 2d 66 69 6c 65 20 6e 69 70 20 49 46 0a 09 73 22 -file nip IF..s"
0850: 20 7e 2f 2e 6e 65 74 32 6f 22 20 24 31 43 30 20 ~/.net2o" $1C0
0860: 6d 6b 64 69 72 2d 70 61 72 65 6e 74 73 20 74 68 mkdir-parents th
0870: 72 6f 77 0a 20 20 20 20 54 48 45 4e 20 3b 0a 0a row. THEN ;..
0880: 3a 20 64 75 6d 70 2d 6b 65 79 73 20 28 20 2d 2d : dump-keys ( --
0890: 20 29 20 20 3f 2e 6e 65 74 32 6f 0a 20 20 20 20 ) ?.net2o.
08a0: 73 22 20 7e 2f 2e 6e 65 74 32 6f 2f 73 65 63 6b s" ~/.net2o/seck
08b0: 65 79 73 2e 6e 32 6f 22 20 72 2f 77 20 6f 70 65 eys.n2o" r/w ope
08c0: 6e 2d 66 69 6c 65 20 74 68 72 6f 77 0a 20 20 20 n-file throw.
08d0: 20 64 75 70 20 3e 72 20 64 75 6d 70 2d 73 6b 65 dup >r dump-ske
08e0: 79 73 20 72 3e 20 63 6c 6f 73 65 2d 66 69 6c 65 ys r> close-file
08f0: 20 74 68 72 6f 77 20 0a 20 20 20 20 73 22 20 7e throw . s" ~
0900: 2f 2e 6e 65 74 32 6f 2f 70 75 62 6b 65 79 73 2e /.net2o/pubkeys.
0910: 6e 32 6f 22 20 72 2f 77 20 6f 70 65 6e 2d 66 69 n2o" r/w open-fi
0920: 6c 65 20 74 68 72 6f 77 0a 20 20 20 20 64 75 70 le throw. dup
0930: 20 3e 72 20 64 75 6d 70 2d 70 6b 65 79 73 20 72 >r dump-pkeys r
0940: 3e 20 63 6c 6f 73 65 2d 66 69 6c 65 20 74 68 72 > close-file thr
0950: 6f 77 20 3b 0a 0a 3a 20 6e 3e 72 20 28 20 78 31 ow ;..: n>r ( x1
0960: 20 2e 2e 20 78 6e 20 6e 20 2d 2d 20 72 3a 78 6e .. xn n -- r:xn
0970: 2e 2e 78 31 20 72 3a 6e 20 29 0a 20 20 20 20 72 ..x1 r:n ). r
0980: 3e 20 7b 20 6e 20 72 65 74 20 7d 0a 20 20 20 20 > { n ret }.
0990: 30 20 20 42 45 47 49 4e 20 20 64 75 70 20 6e 20 0 BEGIN dup n
09a0: 3c 20 20 57 48 49 4c 45 20 20 73 77 61 70 20 3e < WHILE swap >
09b0: 72 20 31 2b 20 20 52 45 50 45 41 54 20 20 3e 72 r 1+ REPEAT >r
09c0: 0a 20 20 20 20 72 65 74 20 3e 72 20 3b 0a 3a 20 . ret >r ;.:
09d0: 6e 72 3e 20 28 20 72 3a 78 6e 2e 2e 78 31 20 72 nr> ( r:xn..x1 r
09e0: 3a 6e 20 2d 2d 20 78 31 20 2e 2e 20 78 6e 20 6e :n -- x1 .. xn n
09f0: 20 29 0a 20 20 20 20 72 3e 20 72 3e 20 7b 20 72 ). r> r> { r
0a00: 65 74 20 6e 20 7d 0a 20 20 20 20 30 20 20 42 45 et n }. 0 BE
0a10: 47 49 4e 20 20 64 75 70 20 6e 20 3c 20 20 57 48 GIN dup n < WH
0a20: 49 4c 45 20 20 72 3e 20 73 77 61 70 20 31 2b 20 ILE r> swap 1+
0a30: 20 52 45 50 45 41 54 0a 20 20 20 20 72 65 74 20 REPEAT. ret
0a40: 3e 72 20 3b 0a 0a 3a 20 73 63 61 6e 2d 6b 65 79 >r ;..: scan-key
0a50: 73 20 28 20 66 64 20 2d 2d 20 29 20 20 30 20 3e s ( fd -- ) 0 >
0a60: 6f 20 67 65 74 2d 6f 72 64 65 72 20 6e 3e 72 0a o get-order n>r.
0a70: 20 20 20 20 6f 6e 6c 79 20 70 72 65 76 69 6f 75 only previou
0a80: 73 20 20 6b 65 79 2d 70 61 72 73 65 72 20 20 69 s key-parser i
0a90: 6e 63 6c 75 64 65 2d 66 69 6c 65 20 20 6e 72 3e nclude-file nr>
0aa0: 20 73 65 74 2d 6f 72 64 65 72 20 6f 3e 20 3b 0a set-order o> ;.
0ab0: 0a 3a 20 3f 73 63 61 6e 2d 6b 65 79 73 20 28 20 .: ?scan-keys (
0ac0: 61 64 64 72 20 75 20 2d 2d 20 29 0a 20 20 20 20 addr u -- ).
0ad0: 72 2f 77 20 6f 70 65 6e 2d 66 69 6c 65 20 30 3d r/w open-file 0=
0ae0: 20 49 46 20 73 63 61 6e 2d 6b 65 79 73 20 45 4c IF scan-keys EL
0af0: 53 45 20 64 72 6f 70 20 54 48 45 4e 20 3b 0a 0a SE drop THEN ;..
0b00: 3a 20 72 65 61 64 2d 6b 65 79 73 20 28 20 2d 2d : read-keys ( --
0b10: 20 29 0a 20 20 20 20 73 22 20 64 65 66 61 75 6c ). s" defaul
0b20: 74 2e 6e 32 6f 22 20 3f 73 63 61 6e 2d 6b 65 79 t.n2o" ?scan-key
0b30: 73 0a 20 20 20 20 73 22 20 7e 2f 2e 6e 65 74 32 s. s" ~/.net2
0b40: 6f 2f 73 65 63 6b 65 79 73 2e 6e 32 6f 22 20 3f o/seckeys.n2o" ?
0b50: 73 63 61 6e 2d 6b 65 79 73 0a 20 20 20 20 73 22 scan-keys. s"
0b60: 20 7e 2f 2e 6e 65 74 32 6f 2f 70 75 62 6b 65 79 ~/.net2o/pubkey
0b70: 73 2e 6e 32 6f 22 20 3f 73 63 61 6e 2d 6b 65 79 s.n2o" ?scan-key
0b80: 73 20 3b 0a 0a 5c 20 73 65 61 72 63 68 20 66 6f s ;..\ search fo
0b90: 72 20 6b 65 79 73 20 62 79 20 6e 61 6d 65 20 61 r keys by name a
0ba0: 6e 64 20 6e 69 63 6b 0a 5c 20 21 21 46 49 58 4d nd nick.\ !!FIXM
0bb0: 45 21 21 20 6e 6f 74 20 6f 70 74 69 6d 69 7a 65 E!! not optimize
0bc0: 64 0a 0a 3a 20 6e 69 63 6b 2d 6b 65 79 20 28 20 d..: nick-key (
0bd0: 61 64 64 72 20 75 20 2d 2d 20 29 20 5c 20 73 65 addr u -- ) \ se
0be0: 61 72 63 68 20 66 6f 72 20 6b 65 79 20 6e 69 63 arch for key nic
0bf0: 6b 6e 61 6d 65 20 61 6e 64 20 6d 61 6b 65 20 63 kname and make c
0c00: 75 72 72 65 6e 74 0a 20 20 20 20 6b 65 79 2d 74 urrent. key-t
0c10: 61 62 6c 65 20 0a 20 20 20 20 5b 3a 20 64 75 70 able . [: dup
0c20: 20 3e 72 20 63 65 6c 6c 2b 20 24 40 20 64 72 6f >r cell+ $@ dro
0c30: 70 20 3e 6f 20 6b 65 2d 6e 69 63 6b 20 24 40 20 p >o ke-nick $@
0c40: 6f 3e 20 32 6f 76 65 72 20 73 74 72 3d 20 49 46 o> 2over str= IF
0c50: 0a 09 72 40 20 6d 61 6b 65 2d 74 68 69 73 6b 65 ..r@ make-thiske
0c60: 79 0a 20 20 20 20 54 48 45 4e 20 20 72 64 72 6f y. THEN rdro
0c70: 70 20 3b 5d 20 23 6d 61 70 20 32 64 72 6f 70 20 p ;] #map 2drop
0c80: 3b 0a 0a 3a 20 6e 61 6d 65 2d 6b 65 79 20 28 20 ;..: name-key (
0c90: 61 64 64 72 20 75 20 2d 2d 20 29 20 5c 20 73 65 addr u -- ) \ se
0ca0: 61 72 63 68 20 66 6f 72 20 6b 65 79 20 6e 61 6d arch for key nam
0cb0: 65 20 61 6e 64 20 6d 61 6b 65 20 63 75 72 72 65 e and make curre
0cc0: 6e 74 0a 20 20 20 20 6b 65 79 2d 74 61 62 6c 65 nt. key-table
0cd0: 20 0a 20 20 20 20 5b 3a 20 64 75 70 20 3e 72 20 . [: dup >r
0ce0: 63 65 6c 6c 2b 20 24 40 20 64 72 6f 70 20 3e 6f cell+ $@ drop >o
0cf0: 20 6b 65 2d 6e 61 6d 65 20 24 40 20 6f 3e 20 32 ke-name $@ o> 2
0d00: 6f 76 65 72 20 73 74 72 3d 20 49 46 0a 09 72 40 over str= IF..r@
0d10: 20 6d 61 6b 65 2d 74 68 69 73 6b 65 79 0a 20 20 make-thiskey.
0d20: 20 20 54 48 45 4e 20 20 72 64 72 6f 70 20 3b 5d THEN rdrop ;]
0d30: 20 23 6d 61 70 20 3b 0a 0a 5c 20 61 63 63 65 70 #map ;..\ accep
0d40: 74 20 66 6f 72 20 70 61 73 73 77 6f 72 64 20 65 t for password e
0d50: 6e 74 72 79 0a 0a 3a 20 61 63 63 65 70 74 2a 20 ntry..: accept*
0d60: 28 20 61 64 64 72 20 75 20 2d 2d 20 75 27 20 29 ( addr u -- u' )
0d70: 0a 20 20 20 20 5c 20 61 63 63 65 70 74 2d 6c 69 . \ accept-li
0d80: 6b 65 20 69 6e 70 75 74 2c 20 62 75 74 20 74 79 ke input, but ty
0d90: 70 65 73 20 2a 20 69 6e 73 74 65 61 64 20 6f 66 pes * instead of
0da0: 20 74 68 65 20 63 68 61 72 61 63 74 65 72 0a 20 the character.
0db0: 20 20 20 64 75 70 20 3e 72 0a 20 20 20 20 42 45 dup >r. BE
0dc0: 47 49 4e 20 20 78 6b 65 79 20 64 75 70 20 23 63 GIN xkey dup #c
0dd0: 72 20 3c 3e 20 57 48 49 4c 45 0a 09 20 20 20 20 r <> WHILE..
0de0: 64 75 70 20 23 62 73 20 3d 20 6f 76 65 72 20 23 dup #bs = over #
0df0: 64 65 6c 20 3d 20 6f 72 20 49 46 0a 09 09 64 72 del = or IF...dr
0e00: 6f 70 20 64 75 70 20 72 40 20 75 3c 20 49 46 0a op dup r@ u< IF.
0e10: 09 09 20 20 20 20 6f 76 65 72 20 2b 20 3e 72 20 .. over + >r
0e20: 78 63 68 61 72 2d 20 72 3e 20 6f 76 65 72 20 2d xchar- r> over -
0e30: 0a 09 09 20 20 20 20 31 20 62 61 63 6b 73 70 61 ... 1 backspa
0e40: 63 65 73 20 73 70 61 63 65 20 31 20 62 61 63 6b ces space 1 back
0e50: 73 70 61 63 65 73 0a 09 09 45 4c 53 45 0a 09 09 spaces...ELSE...
0e60: 20 20 20 20 62 65 6c 6c 0a 09 09 54 48 45 4e 0a bell...THEN.
0e70: 09 20 20 20 20 45 4c 53 45 0a 09 09 2d 72 6f 74 . ELSE...-rot
0e80: 20 78 63 21 2b 3f 20 30 3d 20 49 46 20 20 62 65 xc!+? 0= IF be
0e90: 6c 6c 20 20 45 4c 53 45 20 20 27 2a 27 20 65 6d ll ELSE '*' em
0ea0: 69 74 20 20 54 48 45 4e 0a 09 20 20 20 20 54 48 it THEN.. TH
0eb0: 45 4e 0a 20 20 20 20 52 45 50 45 41 54 20 20 64 EN. REPEAT d
0ec0: 72 6f 70 20 20 6e 69 70 20 72 3e 20 73 77 61 70 rop nip r> swap
0ed0: 20 2d 20 3b 0a 0a 6b 65 79 73 69 7a 65 20 62 75 - ;..keysize bu
0ee0: 66 66 65 72 3a 20 74 65 73 74 6b 65 79 0a 6b 65 ffer: testkey.ke
0ef0: 79 73 69 7a 65 20 62 75 66 66 65 72 3a 20 74 65 ysize buffer: te
0f00: 73 74 73 6b 63 0a 6b 65 79 73 69 7a 65 20 62 75 stskc.keysize bu
0f10: 66 66 65 72 3a 20 70 61 73 73 73 6b 63 0a 0a 3a ffer: passskc..:
0f20: 20 63 68 65 63 6b 2d 6b 65 79 3f 20 28 20 61 64 check-key? ( ad
0f30: 64 72 20 2d 2d 20 66 6c 61 67 20 29 20 20 3e 72 dr -- flag ) >r
0f40: 0a 20 20 20 20 74 65 73 74 6b 65 79 20 72 40 20 . testkey r@
0f50: 62 61 73 65 39 20 63 72 79 70 74 6f 5f 73 63 61 base9 crypto_sca
0f60: 6c 61 72 6d 75 6c 74 0a 20 20 20 20 74 65 73 74 larmult. test
0f70: 6b 65 79 20 6b 65 79 73 69 7a 65 20 70 6b 63 20 key keysize pkc
0f80: 6f 76 65 72 20 73 74 72 3d 20 49 46 20 20 72 40 over str= IF r@
0f90: 20 73 6b 63 20 6b 65 79 73 69 7a 65 20 6d 6f 76 skc keysize mov
0fa0: 65 20 20 74 72 75 65 0a 20 20 20 20 45 4c 53 45 e true. ELSE
0fb0: 20 20 66 61 6c 73 65 20 20 54 48 45 4e 20 20 72 false THEN r
0fc0: 64 72 6f 70 20 3b 0a 0a 33 20 56 61 6c 75 65 20 drop ;..3 Value
0fd0: 70 61 73 73 70 68 72 61 73 65 2d 72 65 74 72 79 passphrase-retry
0fe0: 23 0a 24 31 30 30 20 56 61 6c 75 65 20 70 61 73 #.$100 Value pas
0ff0: 73 70 68 72 61 73 65 2d 64 69 66 66 75 73 65 23 sphrase-diffuse#
1000: 0a 0a 3a 20 67 65 74 2d 70 61 73 73 70 68 72 61 ..: get-passphra
1010: 73 65 20 28 20 61 64 64 72 69 6e 20 2d 2d 20 61 se ( addrin -- a
1020: 64 64 72 6f 75 74 20 29 0a 20 20 20 20 70 61 73 ddrout ). pas
1030: 73 73 6b 63 20 6b 65 79 73 69 7a 65 20 6d 6f 76 sskc keysize mov
1040: 65 20 20 20 77 75 72 73 74 2d 73 6f 75 72 63 65 e wurst-source
1050: 20 72 6f 75 6e 64 73 2d 73 65 74 6b 65 79 0a 20 rounds-setkey.
1060: 20 20 20 6d 65 73 73 61 67 65 20 73 74 61 74 65 message state
1070: 23 20 38 20 2a 20 32 64 75 70 20 61 63 63 65 70 # 8 * 2dup accep
1080: 74 2a 20 64 75 70 20 3e 72 20 73 61 66 65 2f 73 t* dup >r safe/s
1090: 74 72 69 6e 67 20 65 72 61 73 65 0a 20 20 20 20 tring erase.
10a0: 72 3e 20 49 46 0a 09 73 6f 75 72 63 65 2d 69 6e r> IF..source-in
10b0: 69 74 20 77 75 72 73 74 2d 6b 65 79 20 68 61 73 it wurst-key has
10c0: 68 2d 69 6e 69 74 0a 09 6d 65 73 73 61 67 65 20 h-init..message
10d0: 72 6f 75 6e 64 73 68 23 20 72 6f 75 6e 64 73 2d roundsh# rounds-
10e0: 65 6e 63 72 79 70 74 0a 09 70 61 73 73 70 68 72 encrypt..passphr
10f0: 61 73 65 2d 64 69 66 66 75 73 65 23 20 30 20 3f ase-diffuse# 0 ?
1100: 44 4f 20 20 63 3a 64 69 66 66 75 73 65 20 20 4c DO c:diffuse L
1110: 4f 4f 50 20 5c 20 6a 75 73 74 20 74 6f 20 77 61 OOP \ just to wa
1120: 73 74 65 20 74 69 6d 65 20 3b 2d 29 0a 09 77 75 ste time ;-)..wu
1130: 72 73 74 2d 73 74 61 74 65 20 70 61 73 73 73 6b rst-state passsk
1140: 63 20 6b 65 79 73 69 7a 65 20 78 6f 72 73 0a 09 c keysize xors..
1150: 77 75 72 73 74 2d 73 74 61 74 65 20 6b 65 79 73 wurst-state keys
1160: 69 7a 65 20 2b 20 70 61 73 73 73 6b 63 20 6b 65 ize + passskc ke
1170: 79 73 69 7a 65 20 78 6f 72 73 0a 20 20 20 20 54 ysize xors. T
1180: 48 45 4e 20 20 70 61 73 73 73 6b 63 20 3b 0a 0a HEN passskc ;..
1190: 3a 20 6e 65 77 2d 70 61 73 73 70 68 72 61 73 65 : new-passphrase
11a0: 20 28 20 2d 2d 20 29 0a 20 20 20 20 70 61 73 73 ( -- ). pass
11b0: 70 68 72 61 73 65 2d 72 65 74 72 79 23 20 30 20 phrase-retry# 0
11c0: 3f 44 4f 0a 09 63 72 20 2e 22 20 45 6e 74 65 72 ?DO..cr ." Enter
11d0: 20 50 61 73 73 70 68 72 61 73 65 3a 20 22 20 20 Passphrase: "
11e0: 20 20 20 20 20 73 6b 63 20 67 65 74 2d 70 61 73 skc get-pas
11f0: 73 70 68 72 61 73 65 0a 09 74 65 73 74 73 6b 63 sphrase..testskc
1200: 20 6b 65 79 73 69 7a 65 20 6d 6f 76 65 0a 09 63 keysize move..c
1210: 72 20 2e 22 20 52 65 65 6e 74 65 72 20 50 61 73 r ." Reenter Pas
1220: 73 70 68 72 61 73 65 3a 20 22 20 20 20 20 20 73 sphrase: " s
1230: 6b 63 20 67 65 74 2d 70 61 73 73 70 68 72 61 73 kc get-passphras
1240: 65 0a 09 74 65 73 74 73 6b 63 20 6b 65 79 73 69 e..testskc keysi
1250: 7a 65 20 74 75 63 6b 20 73 74 72 3d 20 49 46 20 ze tuck str= IF
1260: 20 75 6e 6c 6f 6f 70 20 20 45 58 49 54 20 20 54 unloop EXIT T
1270: 48 45 4e 0a 20 20 20 20 4c 4f 4f 50 20 20 21 21 HEN. LOOP !!
1280: 6e 6f 6b 65 79 21 21 20 3b 0a 0a 3a 20 64 65 63 nokey!! ;..: dec
1290: 72 79 70 74 2d 73 6b 63 20 20 28 20 2d 2d 20 29 rypt-skc ( -- )
12a0: 0a 20 20 20 20 74 65 73 74 73 6b 63 20 63 68 65 . testskc che
12b0: 63 6b 2d 6b 65 79 3f 20 3f 45 58 49 54 0a 20 20 ck-key? ?EXIT.
12c0: 20 20 70 61 73 73 70 68 72 61 73 65 2d 72 65 74 passphrase-ret
12d0: 72 79 23 20 30 20 3f 44 4f 0a 20 20 20 20 20 20 ry# 0 ?DO.
12e0: 20 63 72 20 2e 22 20 50 61 73 73 70 68 72 61 73 cr ." Passphras
12f0: 65 3a 20 22 0a 20 20 20 20 20 20 20 74 65 73 74 e: ". test
1300: 73 6b 63 20 67 65 74 2d 70 61 73 73 70 68 72 61 skc get-passphra
1310: 73 65 20 63 68 65 63 6b 2d 6b 65 79 3f 20 49 46 se check-key? IF
1320: 20 20 75 6e 6c 6f 6f 70 20 20 45 58 49 54 20 20 unloop EXIT
1330: 54 48 45 4e 0a 20 20 20 20 4c 4f 4f 50 20 20 21 THEN. LOOP !
1340: 21 6e 6f 6b 65 79 21 21 20 3b 0a 0a 3a 20 3e 6b !nokey!! ;..: >k
1350: 65 79 20 28 20 61 64 64 72 20 75 20 2d 2d 20 29 ey ( addr u -- )
1360: 0a 20 20 20 20 6b 65 79 2d 74 61 62 6c 65 20 40 . key-table @
1370: 20 30 3d 20 49 46 20 20 72 65 61 64 2d 6b 65 79 0= IF read-key
1380: 73 20 20 54 48 45 4e 0a 20 20 20 20 6e 69 63 6b s THEN. nick
1390: 2d 6b 65 79 0a 20 20 20 20 74 68 69 73 2d 6b 65 -key. this-ke
13a0: 79 69 64 20 40 20 70 6b 63 20 6b 65 79 73 69 7a yid @ pkc keysiz
13b0: 65 20 6d 6f 76 65 0a 20 20 20 20 6b 65 2d 73 6b e move. ke-sk
13c0: 20 24 40 20 74 65 73 74 73 6b 63 20 73 77 61 70 $@ testskc swap
13d0: 20 6d 6f 76 65 20 20 64 65 63 72 79 70 74 2d 73 move decrypt-s
13e0: 6b 63 20 3b 0a kc ;.