net2o-keys.fs 10.4 KB
Newer Older
bernd's avatar
bernd committed
1
\ net2o key storage
bernd's avatar
bernd committed
2

3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
\ Copyright (C) 2010-2013   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/>.

bernd's avatar
bernd committed
18 19
require mkdir.fs

bernd's avatar
bernd committed
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
\ 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  '' xemit  THEN
	    THEN
    REPEAT  drop  nip r> swap - ;

bernd's avatar
bernd committed
38 39 40 41
\ Keys are passwords and private keys (self-keyed, i.e. private*public key)

$100 Constant keypack#

bernd's avatar
bernd committed
42
2 Value pw-level# \ pw-level# 0 is lowest
bernd's avatar
bernd committed
43 44 45 46 47 48 49 50 51 52 53
\ !!TODO!! we need a way to tell how much we can trust keys
\ passwords need a pw-level (because they are guessable)
\ secrets don't, they aren't. We can quickly decrypt all
\ secret-based stuff, without bothering with slowdowns.
\ So secrets should use normal string decrypt

keypack# mykey-salt# + $10 + Constant keypack-all#

keypack-all# buffer: keypack
keypack-all# buffer: keypack-d

bernd's avatar
bernd committed
54 55
\ hashed key data base

56
cmd-class class
bernd's avatar
bernd committed
57 58
    field: ke-sk \ secret key
    field: ke-pk \ public key
bernd's avatar
bernd committed
59
    field: ke-psk \ preshared key for stateless communication
bernd's avatar
bernd committed
60 61 62 63
    field: ke-nick
    field: ke-prof
    field: ke-sigs
    field: ke-type
bernd's avatar
bernd committed
64
    field: ke-key
bernd's avatar
bernd committed
65 66
    64field: ke-first
    64field: ke-last
bernd's avatar
bernd committed
67
    64field: ke-offset \ offset in key file
68
    0 +field ke-end
bernd's avatar
bernd committed
69
end-class key-entry
bernd's avatar
bernd committed
70

71
Variable key-entry-table
72

bernd's avatar
bernd committed
73 74 75 76
0 Constant key#anon
1 Constant key#user
2 Constant key#group

77 78
0 Value sample-key

bernd's avatar
bernd committed
79
Variable key-table
80

bernd's avatar
bernd committed
81
64Variable key-read-offset
bernd's avatar
bernd committed
82

83
: current-key ( addr u -- o )
bernd's avatar
bernd committed
84 85 86
    2dup keysize umin key-table #@ drop
    dup 0= IF  drop ." unknown key: " 85type cr  0 EXIT  THEN
    cell+ >o ke-pk $! o o> ;
bernd's avatar
bernd committed
87

bernd's avatar
bernd committed
88
: key:new ( addr u -- )
bernd's avatar
bernd committed
89
    \ addr u is the public key
90
    sample-key >o
91
    key-entry-table @ token-table !
bernd's avatar
bernd committed
92 93
    ke-sk ke-end over - erase
    64#-1 ke-last 64!
94 95 96 97
    key-read-offset 64@ ke-offset 64!
    keypack-all# n>64 key-read-offset 64+! o cell- ke-end over -
    2over keysize umin key-table #! o>
    current-key ;
bernd's avatar
bernd committed
98

bernd's avatar
bernd committed
99
\ search for keys - not optimized
bernd's avatar
bernd committed
100

bernd's avatar
bernd committed
101 102 103 104 105
: nick-key ( addr u -- o ) \ search for key nickname
    0 -rot key-table 
    [: cell+ $@ drop cell+ >o ke-nick $@ 2over str= IF
	rot drop o -rot
    THEN  o> ;] #map 2drop ;
bernd's avatar
bernd committed
106

bernd's avatar
bernd committed
107 108 109
: key-exist? ( addr u -- flag )
    key-table #@ d0<> ; 

110 111
Variable strict-keys  strict-keys on

112 113
: .key ( addr u -- ) drop cell+ >o
    ." nick: " ke-nick $@ type cr
bernd's avatar
bernd committed
114 115
    ." ke-pk: " ke-pk $@ 85type cr
    ke-sk @ IF  ." ke-sk: " ke-sk @ keysize 85type cr  THEN
bernd's avatar
bernd committed
116 117
    ." first: " ke-first 64@ .sigdate cr
    ." last: " ke-last 64@ .sigdate cr
118 119
    o> ;

120
: dumpkey ( addr u -- ) drop cell+ >o
bernd's avatar
bernd committed
121 122
    .\" x\" " ke-pk $@ 85type .\" \" key:new" cr
    ke-sk @ IF  .\" x\" " ke-sk @ keysize 85type .\" \" ke-sk sec! +seckey" cr  THEN
123 124 125 126
    '"' emit ke-nick $@ type .\" \" ke-nick $! "
    ke-first 64@ 64>d [: '$' emit 0 ud.r ;] $10 base-execute
    ." . d>64 ke-first 64! " ke-type @ . ." ke-type !"  cr o> ;

127
: .keys ( -- ) key-table [: cell+ $@ .key ;] #map ;
128
: dumpkeys ( -- ) key-table [: cell+ $@ dumpkey ;] #map ;
129

bernd's avatar
bernd committed
130
: .key# ( addr u -- ) keysize umin
131 132
    ." Key '" key-table #@ 0= IF drop EXIT THEN
    cell+ .ke-nick $@ type ." ' ok" cr ;
bernd's avatar
bernd committed
133

bernd's avatar
bernd committed
134
:noname ( addr u -- )
135
    o IF  dest-pubkey @ IF
bernd's avatar
bernd committed
136
	    2dup dest-pubkey $@ keysize umin str= 0= IF
bernd's avatar
bernd committed
137 138
		[: ." want: " dest-pubkey $@ keysize umin 85type cr
		  ." got : " 2dup 85type cr ;] $err
139 140
		true !!wrong-key!!
	    THEN
141
	    .key#  EXIT
142
	THEN  THEN
bernd's avatar
bernd committed
143
    2dup key-exist? 0= IF
144
	strict-keys @ !!unknown-key!!
bernd's avatar
bernd committed
145
	." Unknown key "  .nnb cr
bernd's avatar
bernd committed
146
    ELSE
147
	.key#
bernd's avatar
bernd committed
148
    THEN ; IS check-key
bernd's avatar
bernd committed
149

150 151 152 153
:noname ( pkc -- skc )
    keysize key-table #@ 0= !!unknown-key!!
    cell+ .ke-sk sec@ 0= !!unknown-key!! ; is search-key

bernd's avatar
bernd committed
154
\ get passphrase
bernd's avatar
bernd committed
155

bernd's avatar
bernd committed
156 157 158
3 Value passphrase-retry#
$100 Constant max-passphrase# \ 256 characters should be enough...
max-passphrase# buffer: passphrase
bernd's avatar
bernd committed
159

bernd's avatar
bernd committed
160 161
: passphrase-in ( -- addr u )
    passphrase dup max-passphrase# accept* ;
bernd's avatar
bernd committed
162

bernd's avatar
bernd committed
163
: >passphrase ( addr u -- addr u )
bernd's avatar
bernd committed
164 165 166
    \G create a 512 bit hash of the passphrase
    no-key >c:key c:hash
    keccak-padded c:key> keccak-padded keccak#max 2/ ;
bernd's avatar
bernd committed
167

bernd's avatar
bernd committed
168 169
: get-passphrase ( -- addr u )
    passphrase-in >passphrase ;
bernd's avatar
bernd committed
170

bernd's avatar
bernd committed
171
Variable keys
bernd's avatar
bernd committed
172
2Variable key+len \ current key + len
bernd's avatar
bernd committed
173

bernd's avatar
bernd committed
174
: +key ( addr u -- ) keys sec+[]! ;
bernd's avatar
bernd committed
175 176 177
: +passphrase ( -- )  get-passphrase +key ;
: ">passphrase ( addr u -- ) >passphrase +key ;
: +seckey ( -- )
bernd's avatar
bernd committed
178
    ke-sk @ ke-pk $@ drop keypad ed-dh +key ;
bernd's avatar
bernd committed
179

bernd's avatar
bernd committed
180 181
"" ">passphrase \ following the encrypt-everything paradigm,
\ no password is the empty string!  It's still encrypted!
bernd's avatar
bernd committed
182

bernd's avatar
bernd committed
183 184
\ a secret key just needs a nick and a type.
\ Secret keys can be persons and groups.
bernd's avatar
bernd committed
185

bernd's avatar
bernd committed
186 187
\ a public key needs more: nick, type, profile.
\ The profile is a structured document, i.e. pointed to by a hash.
bernd's avatar
bernd committed
188

bernd's avatar
bernd committed
189 190 191
\ 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).
bernd's avatar
bernd committed
192

bernd's avatar
bernd committed
193 194
\ we store each item in a 256 bytes encrypted string, i.e. with a 16
\ byte salt and a 16 byte checksum.
bernd's avatar
bernd committed
195

196
get-current also net2o-base definitions
bernd's avatar
bernd committed
197

198
cmd-table $@ inherit-table key-entry-table
bernd's avatar
bernd committed
199

200
$10 net2o: newkey ( $:string -- o:key ) $> key:new n:>o ;
201
key-entry-table >table
bernd's avatar
bernd committed
202
+net2o: privkey ( $:string -- ) $> ke-sk sec! +seckey ;
203 204 205
+net2o: keytype ( n -- )  64>n ke-type ! ; \ default: anonymous
+net2o: keynick ( $:string -- )    $> ke-nick $! ;
+net2o: keyprofile ( $:string -- ) $> ke-prof $! ;
206
+net2o: newkeysig ( $:string -- )  $> ke-sigs $+[]! ;
207 208 209
+net2o: keymask ( x -- )  64drop ;
+net2o: keyfirst ( date-ns -- )  ke-first 64! ;
+net2o: keylast  ( date-ns -- )  ke-last 64! ;
210
dup set-current previous
bernd's avatar
bernd committed
211

bernd's avatar
bernd committed
212
gen-table $freeze
213
' context-table is gen-table
214

bernd's avatar
bernd committed
215
key-entry ' new static-a with-allocater to sample-key
216
sample-key >o key-entry-table @ token-table ! o>
217

bernd's avatar
bernd committed
218 219 220 221
: key:code ( -- )
    net2o-code0 keypack keypack-all# erase
    keypack mykey-salt# + cmd0source ! ;
comp: :, also net2o-base ;
bernd's avatar
bernd committed
222

bernd's avatar
bernd committed
223 224 225
also net2o-base definitions

: end:key ( -- )
226
    endwith end-cmd previous
bernd's avatar
bernd committed
227 228 229
    cmdlock unlock ;
comp: :, previous ;

230
set-current previous previous
bernd's avatar
bernd committed
231

bernd's avatar
bernd committed
232 233
: key-crypt ( -- )
    keypack keypack-all#
bernd's avatar
bernd committed
234 235
    key+len 2@ dup $20 = \ is a secret, no need to be slow
    IF  encrypt$  ELSE  pw-level# encrypt-pw$  THEN ;
bernd's avatar
bernd committed
236

bernd's avatar
bernd committed
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
0 Value key-fd

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

: ?key-fd ( -- fd ) key-fd dup ?EXIT drop
    ?.net2o
    "~/.net2o/keyfile.n2o" r/w open-file dup -514 = IF
	2drop "~/.net2o/keyfile.n2o" r/w create-file
    THEN  throw
    dup to key-fd ;

: append-file ( addr u fd -- ) >r
    r@ file-size throw  r@ reposition-file throw
    r@ write-file throw  r> flush-file throw ;

: key>file ( -- )
    keypack keypack-all# ?key-fd append-file ;

: rnd>file ( -- )
    ( keypack keypack-all# >rng$ ) key>file ;

: >keys ( -- )
bernd's avatar
bernd committed
262
    \G add shared secret to list of possible keys
bernd's avatar
bernd committed
263 264 265
    skc pkc keypad ed-dh +key ;

\ key generation
bernd's avatar
bernd committed
266

bernd's avatar
bernd committed
267
: pack-key ( type nick u -- )
bernd's avatar
bernd committed
268
    key:code
bernd's avatar
bernd committed
269
        pkc keysize 2* $, newkey
bernd's avatar
bernd committed
270
	skc keysize $, privkey
bernd's avatar
bernd committed
271
        $, keynick lit, keytype ticks lit, keyfirst
bernd's avatar
bernd committed
272 273 274 275
    end:key ;

: +gen-keys ( type nick u -- )
    gen-keys >keys pack-key key-crypt key>file ;
bernd's avatar
bernd committed
276

bernd's avatar
bernd committed
277 278
: +keypair ( type nick u -- ) +passphrase +gen-keys ;

bernd's avatar
bernd committed
279 280 281 282 283 284 285 286 287 288
: .rvk ." Please write down revoke key: " cr
    skrev $20 bounds DO  ." \ " I 4 85type space I 4 + 4 85type cr 8 +LOOP ;

$40 buffer: nick-buf

: make-key ( -- )
    key#user ." nick: " nick-buf $40 accept nick-buf swap cr
    ." passphrase: " +passphrase keys $[]# 1- keys sec[]@ key+len 2!
    cr +gen-keys .rvk ;

bernd's avatar
bernd committed
289 290
\ read key file

291 292 293 294
: try-decrypt-key ( key u1 -- addr u2 true / false )
    keypack c@ $F and pw-level# u<= IF
	keypack keypack-d keypack-all# move
	keypack-d keypack-all# 2swap
bernd's avatar
bernd committed
295 296
	dup $20 = IF  decrypt$  ELSE  decrypt-pw$  THEN
	?dup-if  EXIT  THEN
297 298
    THEN  2drop false ;

bernd's avatar
bernd committed
299
: try-decrypt ( -- addr u / 0 0 )
bernd's avatar
bernd committed
300
    keys $[]# 0 ?DO
bernd's avatar
bernd committed
301
	I keys sec[]@ try-decrypt-key IF  unloop  EXIT  THEN
302
    LOOP  0 0 ;
bernd's avatar
bernd committed
303 304

: do-key ( addr u / 0 0  -- )
305
    dup 0= IF  2drop  EXIT  THEN
bernd's avatar
bernd committed
306
    sample-key .do-cmd-loop ;
bernd's avatar
bernd committed
307 308 309

: read-key-loop ( -- )
    BEGIN
bernd's avatar
bernd committed
310 311
	?key-fd file-position throw d>64 key-read-offset 64!
	keypack keypack-all# key-fd read-file throw
bernd's avatar
bernd committed
312 313 314
	keypack-all# = WHILE  try-decrypt do-key
    REPEAT ;

bernd's avatar
bernd committed
315
: read-keys ( -- )
bernd's avatar
bernd committed
316
    [: 0. ?key-fd reposition-file throw  read-key-loop ;] catch drop nothrow ;
bernd's avatar
bernd committed
317

bernd's avatar
bernd committed
318
\ select key by nick
bernd's avatar
bernd committed
319

bernd's avatar
bernd committed
320 321
: >key ( addr u -- )
    key-table @ 0= IF  read-keys  THEN
bernd's avatar
bernd committed
322 323
    nick-key >o o 0= IF  EXIT  THEN
    ke-pk $@ pkc swap keysize 2* umin move
bernd's avatar
bernd committed
324
    ke-psk sec@ my-0key sec!
bernd's avatar
bernd committed
325
    ke-sk @ skc keysize move o> ;
bernd's avatar
bernd committed
326

bernd's avatar
bernd committed
327 328
: i'm ( "name" -- ) parse-name >key ;

329
: dest-key ( addr u -- ) dup 0= IF  2drop  EXIT  THEN
bernd's avatar
bernd committed
330
    nick-key >o o 0= !!unknown-key!!
bernd's avatar
bernd committed
331 332 333
    ke-psk sec@ state# umin
    ke-pk $@ keysize umin o>
    dest-pubkey $!  dest-0key sec! ;
334

335
: replace-key 1 /string { rev-addr u -- o } \ revocation ticket
336
    key( ." Replace:" cr o cell- 0 .key )
337
    s" #revoked" dup >r ke-nick $+!
338 339 340
    ke-nick $@ r> - ke-prof $@ ke-sigs ke-type @ ke-key @ 
    rev-addr keysize 2* key:new >o
    ke-key ! ke-type ! [: ke-sigs $+[]! ;] $[]map ke-prof $! ke-nick $!
341 342
    rev-addr keysize 2* ke-pk $!
    rev-addr u + 1- dup c@ 2* - $10 - dup 64@ ke-first 64! 64'+ 64@ ke-last 64!
343
    key( ." with:" cr o cell- 0 .key ) o o> ;
344

345 346 347
:noname ( revaddr u1 keyaddr u2 -- o )
    current-key >o replace-key o> >o skc keysize ke-sk sec!
    o o> ; is renew-key
348

349 350
also net2o-base
: fetch-id, ( id-addr u -- )
351
    $, dht-id dht-host? endwith ;
352 353 354 355
: fetch-host, ( nick u -- )
    nick-key .ke-pk $@ fetch-id, ;
previous

bernd's avatar
bernd committed
356 357 358 359
0 [IF]
Local Variables:
forth-local-words:
    (
360
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
bernd's avatar
bernd committed
361 362 363 364 365 366
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     ("[a-z0-9]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
    )
forth-local-indent-words:
    (
367
     (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate)
bernd's avatar
bernd committed
368 369 370 371 372
     (("[:") (0 . 1) (0 . 1) immediate)
     ((";]") (-1 . 0) (0 . -1) immediate)
    )
End:
[THEN]