Artifact e49bc59cb412293f5e7a5e98c773869d197a63f6:

• File net2o-keys.fs — part of check-in [7b2865b60c] at 2012-12-11 01:00:09 on branch trunk — Key file 'data base' (user: bernd size: 4480)

\ key handling

require mkdir.fs

\ hashed key data base

begin-structure key-entry
field: ke-sk
field: ke-nick
field: ke-name
field: ke-sigs
64field: ke-created
64field: ke-expires
end-structure

key-entry buffer: sample-key

Variable key-table
Variable this-key
sample-key this-key ! \ dummy

: new-key ( addr u -- )
    \ addr u is the public key
    sample-key key-entry 2dup erase
    2over key-table #! key-table #@ drop this-key ! ;

: (digits>$) ( addr u -- addr' u' ) save-mem
    >r dup dup r> bounds ?DO
	I 2 s>number drop over c! char+ 
    2 +LOOP  over - ;

: hex>$ ( addr u -- addr' u' )
    ['] (digits>$) $10 base-execute ;

: x" ( "hexstring" -- addr u )
    '"' parse hex>$ ;
compile> execute postpone SLiteral ;

Vocabulary key-parser

also key-parser definitions

: id: ( "id" -- ) 0 parse hex>$ new-key ;
: sk: ( "sk" -- ) 0 parse hex>$ this-key @ ke-sk $! ;
: nick: ( "sk" -- ) 0 parse this-key @ ke-nick $! ;
: name: ( "sk" -- ) 0 parse this-key @ ke-name $! ;
: created: ( "number" -- )  parse-name s>number d>64 this-key @ ke-created 64! ;
: expires: ( "number" -- )  parse-name s>number d>64 this-key @ ke-expires 64! ;

previous definitions

: .key ( addr -- )  dup @ 0= IF  drop  EXIT  THEN
    ." id: "   dup $@ xtype cr cell+ $@ drop >r
    r@ ke-sk   @ IF  ." sk: "   r@ ke-sk $@ xtype cr  THEN
    r@ ke-nick @ IF  ." nick: " r@ ke-nick $@ type cr  THEN
    r@ ke-name @ IF  ." name: " r@ ke-name $@ type cr  THEN
    r@ ke-created 64@ 64dup 64-0= IF  64drop
    ELSE  ." created: " 64>d d. cr  THEN
    r@ ke-expires 64@ 64dup 64-0= IF  64drop
    ELSE  ." expires: " 64>d d. cr  THEN
    rdrop cr ;

: dump-keys ( fd -- ) [: key-table ['] .key #map ;] swap outfile-execute ;

: n>r ( x1 .. xn n -- r:xn..x1 r:n )
    r> { n ret }
    0  BEGIN  dup n <  WHILE  swap >r 1+  REPEAT  >r
    ret >r ;
: nr> ( r:xn..x1 r:n -- x1 .. xn n )
    r> r> { ret n }
    0  BEGIN  dup n <  WHILE  r> swap 1+  REPEAT
    ret >r ;

: scan-keys ( fd -- )  get-order n>r
    only previous  key-parser  include-file  nr> set-order ;

\ accept for password entry

: accept* ( addr u -- u' )
    \ accept-like input, but types * instead of the character
    dup >r
    BEGIN  xkey dup #cr <> WHILE
	    dup #bs = over #del = or IF
		drop dup r@ u< IF
		    over + >r xchar- r> over -
		    1 backspaces space 1 backspaces
		ELSE
		    bell
		THEN
	    ELSE
		-rot xc!+? 0= IF  bell  ELSE  '*' emit  THEN
	    THEN
    REPEAT  drop  nip r> swap - ;

: ?.net2o ( -- )
    s" ~/.net2o" r/o open-file nip IF
	s" ~/.net2o" $1C0 mkdir-parents throw
    THEN ;

: keys-in ( pkc skc addr u -- )
    r/o open-file throw { fd } swap
    keysize fd read-file throw keysize <> !!nokey!!
    keysize fd read-file throw keysize <> !!nokey!!
    fd close-file throw ;

: keys-out ( pkc skc addr u -- )
    r/w create-file throw { fd } swap
    keysize fd write-file throw
    keysize fd write-file throw
    fd close-file throw ;

keysize buffer: testkey
keysize buffer: testskc
keysize buffer: passskc

: check-key? ( addr -- flag )  >r
    testkey r@ base9 crypto_scalarmult
    testkey keysize pkc over str= IF  r@ skc keysize move  true
    ELSE  false  THEN  rdrop ;

3 Value passphrase-retry#
$100 Value passphrase-diffuse#

: get-passphrase ( addrin -- addrout )
    passskc keysize move   wurst-source !key
    message state# 8 * 2dup accept* dup >r safe/string erase
    r> IF
	source-init wurst-key hash-init
	message roundsh# rounds
	passphrase-diffuse# 0 ?DO  start-diffuse  LOOP \ just to waste time ;-)
	wurst-state passskc keysize xors
	wurst-state keysize + passskc keysize xors
    THEN  passskc ;

Variable keyfile

: >key-name ( addr u -- )
    s" ~/.net2o/" keyfile $! 
    keyfile $+! s" .ecc" keyfile $+! ;

: key-name ( -- )  keyfile @ ?EXIT
    ." ID name: " pad 100 accept pad swap >key-name ;

: read-keys ( -- )  ?.net2o key-name
    pkc testskc keyfile $@ keys-in
    testskc check-key? ?EXIT
    passphrase-retry# 0 ?DO
	cr ." Passphrase: "
	testskc get-passphrase check-key? IF  unloop  EXIT  THEN
    LOOP  !!nokey!! ;

: new-passphrase ( -- )
    passphrase-retry# 0 ?DO
	cr ." Enter Passphrase: "       skc get-passphrase
	testskc keysize move
	cr ." Reenter Passphrase: "     skc get-passphrase
	testskc keysize tuck str= IF  unloop  EXIT  THEN
    LOOP  !!nokey!! ;

: write-keys ( -- )  ?.net2o key-name
    new-passphrase
    pkc testskc keyfile $@ keys-out ;

: ?keypair ( -- )
    ['] read-keys catch IF  nothrow gen-keys write-keys  THEN ;