net2o-crypt.fs 11.5 KB
Newer Older
bernd's avatar
bernd committed
1 2
\ symmetric encryption and decryption

3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
\ Copyright (C) 2011-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
64 Constant state#
19

bernd's avatar
bernd committed
20 21
Variable my-0key

bernd's avatar
bernd committed
22 23 24
user-o keybuf

state# 2* Constant state2#
25
KEYBYTES Constant keysize \ our shared secred is only 32 bytes long
bernd's avatar
bernd committed
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49

object class
    state2# uvar key-assembly
    state2# uvar ivs-assembly
    state2# uvar no-key \ just zeros for no key
    state# uvar mykey \ instance's private key
    state# uvar oldmykey \ previous private key
    
    \ key storage
    \ client keys
    keysize uvar pkc   \ pubkey
    keysize uvar pk1   \ pubkey 1 for revokation
    keysize uvar skc   \ secret key
    keysize uvar sk1   \ secret key 1 for revokation (will not last)
    keysize uvar pkrev \ pubkey for revoking keys
    keysize uvar skrev \ secret for revoking keys
    keysize uvar stpkc \ server temporary keypair - once per connection setup
    keysize uvar stskc
    keysize uvar oldpkc   \ previous pubkey after revocation
    keysize uvar oldskc   \ previous secret key after revocation
    keysize uvar oldpkrev \ previous revocation pubkey after revocation
    keysize uvar oldskrev \ previous revocation secret after revocation
    \ shared secred
    keysize uvar keypad
50
    1 64s uvar last-mykey
bernd's avatar
bernd committed
51 52 53 54
end-class keybuf-c

: init-keybuf ( -- )
    keybuf @ ?EXIT \ we have only one global keybuf
bernd's avatar
bernd committed
55
    keybuf-c >osize @ kalloc keybuf ! ;
bernd's avatar
bernd committed
56 57 58

init-keybuf

59 60 61 62 63 64 65 66 67 68
#10.000.000.000 d>64 64Value delta-mykey# \ new mykey every 10 seconds

: init-mykey ( -- )
    ticks delta-mykey# 64+ last-mykey 64!
    mykey oldmykey state# move
    state# rng$ mykey swap move
    genkey( ." mykey: " mykey state# xtype cr ) ;

: ?new-mykey ( -- )
    last-mykey 64@ ticker 64@ 64- 64-0< IF  init-mykey  THEN ;
bernd's avatar
bernd committed
69

70 71 72 73 74
: move-rep ( srcaddr u1 destaddr u2 -- )
    bounds ?DO
	I' I - umin 2dup I swap move
    dup +LOOP  2drop ;

bernd's avatar
bernd committed
75
: >crypt-key ( addr u -- ) key( dup . )
bernd's avatar
bernd committed
76
    dup 0= IF  2drop no-key state#  THEN
77
    key-assembly state# + state# move-rep
bernd's avatar
bernd committed
78
    key-assembly key( ." >crypt-key " dup state2# xtype cr )
79
    >c:key ;
bernd's avatar
bernd committed
80
: >crypt-source ( addr u -- )
81
    key-assembly state# move-rep ;
bernd's avatar
bernd committed
82 83 84 85 86

\ regenerate ivs is a buffer swapping function:
\ regenerate half of the ivs per time, when you reach the middle of the other half
\ of the ivs buffer.

bernd's avatar
bernd committed
87
: dest-a/b ( addr u -- addr1 u1 )
bernd's avatar
bernd committed
88
    2/  dest-ivslastgen @ 1 = IF  dup >r + r>  THEN ;
bernd's avatar
bernd committed
89

bernd's avatar
bernd committed
90 91
: clear-replies ( -- )
    dest-replies @ dest-size @ addr>replies dest-a/b
bernd's avatar
bernd committed
92
    cmd( ." Clear replies " over hex. dup hex. cr )
bernd's avatar
bernd committed
93
    erase ;
bernd's avatar
bernd committed
94

95
: crypt-key$ ( -- addr u )
bernd's avatar
bernd committed
96
    o 0= IF  no-key state#  ELSE  crypto-key sec@  THEN ;
97

98
: default-key ( -- )
bernd's avatar
bernd committed
99
    cmd( ." Default-key " cr )
bernd's avatar
bernd committed
100
    c:0key ;
bernd's avatar
bernd committed
101

102 103 104 105 106
: addr>assembly ( addr flag -- )
    [ acks# invert 8 lshift ]L and
    ivs-assembly state# + 64'+ w!
    ivs-assembly state# + 64! ; \ the address is part of the key

bernd's avatar
bernd committed
107 108
User last-ivskey

bernd's avatar
bernd committed
109
: ivs>source? ( o:map -- )  o 0= IF  default-key  EXIT  THEN
bernd's avatar
bernd committed
110
    dest-addr 64@ dest-vaddr 64@ 64- 64dup dest-size @ n>64 64u<
111
    IF  64dup dest-flags w@ addr>assembly
bernd's avatar
bernd committed
112
	\ the flags, too, except the ack toggle bits
bernd's avatar
bernd committed
113 114
	64>n addr>keys dest-ivs $@ drop over + dup last-ivskey !
	ivs-assembly state# move
bernd's avatar
bernd committed
115
	key( ." key: " ivs-assembly state# + 64@ $64. ivs-assembly state# 2* xtype cr )
bernd's avatar
bernd committed
116
	ivs-assembly >c:key regen-ivs  EXIT  THEN  64drop
117 118
    dest-flags 1+ c@ stateless# and
    IF  default-key  ELSE  true !!inv-dest!!  THEN ;
119

120
: crypt-buf-init ( map -- ) >r
bernd's avatar
bernd committed
121
    o IF  r@ .ivs>source?  ELSE  default-key  THEN
bernd's avatar
bernd committed
122
    ( cmd( ." key: " c:key@ c:key# xtype cr ) rdrop ;
bernd's avatar
bernd committed
123

124
: crypt-key-init ( addr u key u -- addr' u' ) 2>r
bernd's avatar
bernd committed
125 126
    over mykey-salt# >crypt-source
    2r> >crypt-key 
127
    mykey-salt# safe/string
bernd's avatar
bernd committed
128
    key( ." key init: " c:key@ c:key# .nnb cr ) c:diffuse ;
bernd's avatar
bernd committed
129

130 131
: crypt-key-setup ( addr u1 key u2 -- addr' u' )
    2>r over >r  rng@ rng@ r> 128! 2r> crypt-key-init ;
132

bernd's avatar
bernd committed
133
: encrypt$ ( addr u1 key u2 -- )
134
    crypt-key-setup  2 64s - 0 c:encrypt+auth ;
135

136
: decrypt$ ( addr u1 key u2 -- addr' u' flag )
137
    crypt-key-init 2 64s - 2dup 0 c:decrypt+auth ;
138

bernd's avatar
bernd committed
139 140
\ passphraese encryption needs to diffuse a lot after mergin in the salt

141
: crypt-pw-setup ( addr u1 key u2 n -- addr' u' n' ) { n }
bernd's avatar
bernd committed
142
    2>r over >r  rng@ rng@ r@ 128!
143
    r@ c@ n $F0 mux r> c! 2r> crypt-key-init $100 n 2* lshift ;
bernd's avatar
bernd committed
144

bernd's avatar
bernd committed
145 146 147 148 149
: pw-diffuse ( diffuse# -- )
    0 ?DO  c:diffuse  LOOP ; \ just to waste time ;-)
: pw-setup ( addr u -- diffuse# )
    \G compute between 256 and ridiculously many iteratsions
    drop c@ $F and 2* $100 swap lshift ;
bernd's avatar
bernd committed
150

bernd's avatar
bernd committed
151
: encrypt-pw$ ( addr u1 key u2 n -- )
152
    crypt-pw-setup  pw-diffuse  2 64s - 0 c:encrypt+auth ;
bernd's avatar
bernd committed
153 154

: decrypt-pw$ ( addr u1 key u2 -- addr' u' flag )  2over pw-setup >r
155
    crypt-key-init   r> pw-diffuse  2 64s - 2dup 0 c:decrypt+auth ;
bernd's avatar
bernd committed
156 157 158

\ encrypt with own key

bernd's avatar
bernd committed
159
: mykey-encrypt$ ( addr u -- ) +calc mykey state# encrypt$ +enc ;
160

bernd's avatar
bernd committed
161
: mykey-decrypt$ ( addr u -- addr' u' flag )
162 163 164
    +calc 2dup $>align mykey state# decrypt$
    IF  +enc 2nip true  EXIT  THEN  2drop
    $>align oldmykey state# decrypt$ +enc ;
165

166
: outbuf-encrypt ( map -- ) +calc
167 168
    crypt-buf-init outbuf packet-data +cryptsu
    outbuf 1+ c@ c:encrypt+auth +enc ;
bernd's avatar
bernd committed
169

170
: inbuf-decrypt ( map -- flag ) +calc
171 172
    crypt-buf-init inbuf packet-data +cryptsu
    inbuf 1+ c@ c:decrypt+auth +enc ;
bernd's avatar
bernd committed
173

bernd's avatar
bernd committed
174 175
: set-0key ( keyaddr u -- )
    dup IF
176
	ivs-assembly state# move-rep
177
    ELSE
bernd's avatar
bernd committed
178
	2drop ivs-assembly state# erase
bernd's avatar
bernd committed
179
    THEN
180
\    ." 0key: " ivs-assembly state# 2* 85type cr
bernd's avatar
bernd committed
181
    ivs-assembly >c:key ;
182

bernd's avatar
bernd committed
183
: try-0decrypt ( addr -- flag )  sec@ set-0key
184 185 186 187
    inbuf packet-data tmpbuf swap 2dup 2>r $10 + move
    2r> +cryptsu
    inbuf 1+ c@ c:decrypt+auth +enc
    dup IF  tmpbuf inbuf packet-data move  THEN ;
188

189
: inbuf0-decrypt ( -- flag ) +calc
bernd's avatar
bernd committed
190
    inbuf addr 64@ inbuf flags w@ addr>assembly
bernd's avatar
bernd committed
191
    my-0key try-0decrypt dup IF  EXIT  THEN  drop
192
    false [: try-0decrypt or dup 0= ;] search-0key ;
bernd's avatar
bernd committed
193

194
: outbuf0-encrypt ( -- ) +calc
bernd's avatar
bernd committed
195
    outbuf addr 64@ outbuf flags w@ addr>assembly
bernd's avatar
bernd committed
196
    o IF  dest-0key  ELSE  my-0key  THEN  sec@ set-0key
197 198 199
    outbuf packet-data +cryptsu
    outbuf 1+ c@ c:encrypt+auth +enc ;

bernd's avatar
bernd committed
200
\ IVS
bernd's avatar
bernd committed
201

bernd's avatar
bernd committed
202
Variable do-keypad
bernd's avatar
bernd committed
203
Sema regen-sema
bernd's avatar
bernd committed
204

bernd's avatar
bernd committed
205
: keypad$ ( -- addr u )
bernd's avatar
bernd committed
206
    do-keypad sec@ dup 0= IF  2drop  crypto-key sec@  THEN ;
bernd's avatar
bernd committed
207

bernd's avatar
bernd committed
208
: >crypt-key-ivs ( -- )
bernd's avatar
bernd committed
209 210
    o 0= IF  no-key state#  ELSE  keypad$  THEN
    crypt( ." ivs key: " 2dup .nnb cr )
bernd's avatar
bernd committed
211
    >crypt-key ;
bernd's avatar
bernd committed
212

bernd's avatar
bernd committed
213
: regen-ivs/2 ( -- )
bernd's avatar
bernd committed
214
    c:key@ >r
215
    dest-ivsgen @ key( ." regen-ivs/2 " dup c:key# .nnb cr ) c:key!
bernd's avatar
bernd committed
216
    clear-replies
217
    dest-ivs $@ dest-a/b c:prng
bernd's avatar
bernd committed
218
    2 dest-ivslastgen xor! r> c:key! ;
bernd's avatar
bernd committed
219

bernd's avatar
bernd committed
220 221
: regen-ivs-all ( o:map -- ) [: c:key@ >r
      dest-ivsgen @ key( ." regen-ivs " dup c:key# .nnb cr ) c:key!
222
      dest-ivs $@ c:prng r> c:key! ;]
bernd's avatar
bernd committed
223 224
    regen-sema c-section ;

bernd's avatar
bernd committed
225
: rest+ ( addr u -- addr u )
226
    dest-ivsrest $@len IF
bernd's avatar
bernd committed
227
	2dup dest-ivsrest $@ rot umin >r swap r@ move
228 229 230 231 232 233 234 235 236 237 238
	r@ safe/string
	dest-ivsrest 0 r> $del
    THEN ;

: rest-prng ( addr u -- )
    rest+
    2dup dup keccak#max negate and safe/string 2>r
    keccak#max negate and c:prng
    2r> dup IF
	keccak#max dest-ivsrest $!len  dest-ivsrest $@ c:prng
	rest+
bernd's avatar
bernd committed
239
    THEN  2drop ;
240 241 242

: regen-ivs-part ( new-back -- )
    [: c:key@ >r
bernd's avatar
bernd committed
243 244
      dest-ivsgen @
      key( ." regen-ivs-part " dest-back @ hex. over hex. dup c:key# .nnb cr )
bernd's avatar
bernd committed
245
      regen( ." regen-ivs-part " dest-back @ hex. over hex. dup c:key# .nnb cr )
bernd's avatar
bernd committed
246 247 248 249
      c:key!
      dest-back @ U+DO
	  I I' fix-size dup { len }
	  addr>keys >r addr>keys >r dest-ivs $@ r> safe/string r> umin
250
	    rest-prng
bernd's avatar
bernd committed
251 252
      len +LOOP
      key( ." regen-ivs-part' " dest-ivsgen @ c:key# .nnb cr )
bernd's avatar
bernd committed
253
      regen( ." regen-ivs-part' " dest-ivsgen @ c:key# .nnb cr )
bernd's avatar
bernd committed
254
      r> c:key! ;] regen-sema c-section ;
bernd's avatar
bernd committed
255

bernd's avatar
bernd committed
256
: (regen-ivs) ( offset o:map -- )
257
    dest-ivs $@len 2/ 2/ / dest-ivslastgen @ =
bernd's avatar
bernd committed
258
    IF	regen-ivs/2  THEN ;
259 260
' (regen-ivs) code-class to regen-ivs
' (regen-ivs) rcode-class to regen-ivs
bernd's avatar
bernd committed
261

262 263 264
: one-ivs ( addr -- )
    @ >o c:key@ >r
    key-assembly state2# c:prng
bernd's avatar
bernd committed
265
    dest-ivsgen @ c:key!  key-assembly >c:key
266
    dest-size @ addr>keys dest-ivs $!len
267 268
    dest-ivs $@ c:prng
    r> c:key! o> ;
bernd's avatar
bernd committed
269

270
: clear-keys ( -- )
bernd's avatar
bernd committed
271
    crypto-key sec-off  tskc KEYBYTES erase  stskc KEYBYTES erase ;
272 273 274 275 276 277 278

\ We generate a shared secret out of three parts:
\ 64 bytes IV, 32 bytes from the one-time-keys and
\ 32 bytes from the permanent keys

$60 Constant rndkey#

279
: receive-ivs ( -- )
280 281
    genkey( ." ivs key: " c:key@ c:key# over rndkey# xtype cr
            ." con key: " rndkey# /string xtype cr )
282
    code-map one-ivs   code-rmap one-ivs
283 284
    data-map one-ivs   data-rmap one-ivs
    clear-keys ;
285 286

: send-ivs ( -- )
287 288
    genkey( ." ivs key: " c:key@ c:key# over rndkey# xtype cr
            ." con key: " rndkey# /string xtype cr )
289
    code-rmap one-ivs  code-map one-ivs
290 291
    data-rmap one-ivs  data-map one-ivs
    clear-keys ;
292 293

: ivs-strings ( addr u -- )
294
    dup state# <> !!ivs!! >crypt-source >crypt-key-ivs ;
295

bernd's avatar
bernd committed
296 297
\ public key encryption

298 299 300
\ the theory here is that pkc*sks = pks*skc
\ because pk=base*sk, so base*skc*sks = base*sks*skc
\ base and pk are points on the curve, sk is a skalar
bernd's avatar
bernd committed
301
\ we send our public key and query the server's public key.
bernd's avatar
bernd committed
302 303
: gen-keys ( -- )
    \g generate revocable keypair
bernd's avatar
bernd committed
304
    sk1 pk1 ed-keypair \ generate first keypair
bernd's avatar
bernd committed
305
    skrev pkrev ed-keypair \ generate keypair for recovery
bernd's avatar
bernd committed
306
    sk1 pkrev skc pkc ed-keypairx \ generate real keypair
307
    genkey( ." gen key: " skc keysize xtype cr ) ;
bernd's avatar
bernd committed
308 309
: check-rev? ( -- flag )
    \g check generated key if revocation is possible
bernd's avatar
bernd committed
310
    skrev pkrev sk>pk pkrev dup sk-mask pk1 keypad ed-dh pkc keysize str= ;
311 312 313 314
: gen-tmpkeys ( -- pk addr ) tskc tpkc ed-keypair tpkc keysize
    genkey( ." tmp key: " tskc keysize xtype cr ) ;
: gen-stkeys ( -- ) stskc stpkc ed-keypair
    genkey( ." tmpskey: " stskc keysize xtype cr ) ;
bernd's avatar
bernd committed
315 316

\ setting of keys
317

318
: set-key ( addr -- ) o 0= IF drop  ." key, no context!" cr  EXIT  THEN
bernd's avatar
bernd committed
319 320
    keysize crypto-key sec!
    ." set key to:" o crypto-key sec@ .nnb cr ;
bernd's avatar
bernd committed
321

bernd's avatar
bernd committed
322
: ?keysize ( u -- )
bernd's avatar
bernd committed
323
    keysize <> !!keysize!! ;
bernd's avatar
bernd committed
324

325
Defer check-key \ check if we know that key
326
Defer search-key \ search if that is one of our pubkeys
bernd's avatar
bernd committed
327

328 329 330 331 332 333
: key-stage2 ( pk sk -- ) >r
    keypad$ keysize <> !!no-tmpkey!!
    r> rot keypad ed-dhx do-keypad sec+! ;
: key-rest ( addr u sk -- ) >r
    ?keysize dup keysize [: check-key ;] $err
    dup keysize pubkey $! r> key-stage2 ;
334
: net2o:receive-key ( addr u -- )
335
    o 0= IF  2drop EXIT  THEN  pkc keysize mpubkey $! skc key-rest ;
336
: net2o:keypair ( pkc uc pk u -- )
337
    o 0= IF  2drop EXIT  THEN
338
    2dup mpubkey $! ?keysize search-key key-rest ;
339 340
: net2o:receive-tmpkey ( addr u -- )  ?keysize \ dup keysize .nnb cr
    o 0= IF  gen-stkeys stskc  ELSE  tskc  THEN \ dup keysize .nnb cr
bernd's avatar
bernd committed
341
    swap keypad ed-dh
bernd's avatar
bernd committed
342
    o IF  do-keypad sec!  ELSE  2drop  THEN
343
    ( keypad keysize .nnb cr ) ;
bernd's avatar
bernd committed
344

bernd's avatar
bernd committed
345
: tmpkey@ ( -- addr u )
bernd's avatar
bernd committed
346
    do-keypad sec@  dup ?EXIT  2drop
bernd's avatar
bernd committed
347
    keypad keysize ;
bernd's avatar
bernd committed
348

bernd's avatar
bernd committed
349
: net2o:update-key ( -- )
bernd's avatar
bernd committed
350
    do-keypad sec@ dup IF
bernd's avatar
bernd committed
351
	key( ." store key, o=" o hex. 2dup .nnb cr ) crypto-key sec!
bernd's avatar
bernd committed
352
	do-keypad sec-off
353 354 355
	EXIT
    THEN
    2drop ;
bernd's avatar
bernd committed
356 357 358 359 360 361 362 363 364 365 366 367

0 [IF]
Local Variables:
forth-local-words:
    (
     (("debug:" "field:" "sffield:" "dffield:" "64field:") non-immediate (font-lock-type-face . 2)
      "[ \t\n]" t name (font-lock-variable-name-face . 3))
     ("[a-z0-9]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
    )
End:
[THEN]