Check-in [30bcd87cd1]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Try to make otrify work with encrypted messages — tricky, still doesn't work
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:30bcd87cd10a9c2c884c04d87369e1087e1efdab
User & Date: bernd 2019-07-15 23:36:12
Context
2019-07-26
06:17
Checkin from holiday check-in: 2ef7582d7f user: bernd tags: trunk
2019-07-15
23:36
Try to make otrify work with encrypted messages — tricky, still doesn't work check-in: 30bcd87cd1 user: bernd tags: trunk
21:37
Add chat permission settings check-in: 77cdb0b452 user: bernd tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to crypt.fs.

45
46
47
48
49
50
51

52

53
54
55
56
57
58
59
...
577
578
579
580
581
582
583

584
585
586
587
588
589
590
...
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
    $100      uvar vaultkey \ buffers for vault
    $100      uvar keydump-buf  \ buffer for dumping keys
    state2#   uvar vkey \ maximum size for session key
    state2#   uvar voutkey \ for keydump
    keysize   uvar keygendh
    tf_ctx_256 uvar tf-key
    keysize   uvar tf-out

    $10       uvar tf-hashout

    1 64s     uvar last-mykey
    cell      uvar keytmp-up
end-class keytmp-c

user-o keybuf \ storage for secure permanent keys

object uclass keybuf
................................................................................
	dup 0= IF  nip nip rdrop  EXIT  THEN
	swap .ke-sksig sec@ drop swap 2swap
	ed-quick-verify 0= sig-wrong and +sigquick
    THEN
    rdrop ;

: date-sig? ( addr u pk -- addr u flag )

    >r >date r> verify-sig ;
: pk-sig? ( addr u -- addr u' flag )
    dup sigpksize# u< IF  sig-unsigned  EXIT  THEN
    2dup sigpksize# - c:0key
    2dup c:hash + date-sig? ;
: pk-quick-sig? ( addr u -- addr u' flag )
    dup sigpksize# u< IF  sig-unsigned  EXIT  THEN
................................................................................
    get1 get0 sct0 ge25519*
    dup get1 ge25519-pack
    $80 swap ( over ) $1F + xorc!
    ( keysize 85type forth:cr ) ;
: decrypt-sig? ( key u msg u sig -- addr u sigerr )
    { pksig } $make -5 { w^ msg err }
    msg $@ 2swap decrypt$ IF

	pksig sigpksize# over date-sig? to err  2drop
	err 0= IF
	    pksig pktmp modkey>
	    pksig sigpksize# keysize /string
	    pktmp keysize
	    2rot [: type type type ;] $tmp
	    2dup + 2 - $7F swap andc!
	    msg $free
	    err  EXIT  THEN  THEN
    2drop msg $free  0 0 err ;

: .encsign ( -- )
    +sig sigdate +date
    sktmp pktmp sk@ drop >modkey
    pktmp keysize type  sigdate datesize# type
    sig-params 2drop sktmp pktmp ed-sign
    2dup + 1- $80 swap orc! type
    keysize emit ;






\\\
Local Variables:
forth-local-words:
    (
     (("event:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     (("debug:" "field:" "2field:" "sffield:" "dffield:" "64field:" "uvar" "uvalue") non-immediate (font-lock-type-face . 2)







>

>







 







>







 







>


<

|






|
|
<
|
|



>
>
>
>
>







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
...
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
...
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
    $100      uvar vaultkey \ buffers for vault
    $100      uvar keydump-buf  \ buffer for dumping keys
    state2#   uvar vkey \ maximum size for session key
    state2#   uvar voutkey \ for keydump
    keysize   uvar keygendh
    tf_ctx_256 uvar tf-key
    keysize   uvar tf-out
    keysize   uvar pkmod
    $10       uvar tf-hashout
    keccak#   uvar predate-key
    1 64s     uvar last-mykey
    cell      uvar keytmp-up
end-class keytmp-c

user-o keybuf \ storage for secure permanent keys

object uclass keybuf
................................................................................
	dup 0= IF  nip nip rdrop  EXIT  THEN
	swap .ke-sksig sec@ drop swap 2swap
	ed-quick-verify 0= sig-wrong and +sigquick
    THEN
    rdrop ;

: date-sig? ( addr u pk -- addr u flag )
    c:key@ c:key# predate-key keccak# smove
    >r >date r> verify-sig ;
: pk-sig? ( addr u -- addr u' flag )
    dup sigpksize# u< IF  sig-unsigned  EXIT  THEN
    2dup sigpksize# - c:0key
    2dup c:hash + date-sig? ;
: pk-quick-sig? ( addr u -- addr u' flag )
    dup sigpksize# u< IF  sig-unsigned  EXIT  THEN
................................................................................
    get1 get0 sct0 ge25519*
    dup get1 ge25519-pack
    $80 swap ( over ) $1F + xorc!
    ( keysize 85type forth:cr ) ;
: decrypt-sig? ( key u msg u sig -- addr u sigerr )
    { pksig } $make -5 { w^ msg err }
    msg $@ 2swap decrypt$ IF
	pksig pkmod modkey> \ key modification without date
	pksig sigpksize# over date-sig? to err  2drop
	err 0= IF

	    pksig sigpksize# keysize /string
	    pkmod keysize
	    2rot [: type type type ;] $tmp
	    2dup + 2 - $7F swap andc!
	    msg $free
	    err  EXIT  THEN  THEN
    2drop msg $free  0 0 err ;

: .encsign-rest ( -- )
    sigdate +date

    sigdate datesize# type
    sig-params 2drop sktmp pkmod ed-sign
    2dup + 1- $80 swap orc! type
    keysize emit ;

: .encsign ( -- )
    +sig
    sktmp pkmod sk@ drop >modkey
    pkmod keysize type .encsign-rest ;

\\\
Local Variables:
forth-local-words:
    (
     (("event:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     (("debug:" "field:" "2field:" "sffield:" "dffield:" "64field:" "uvar" "uvalue") non-immediate (font-lock-type-face . 2)

Changes to gui.fs.

411
412
413
414
415
416
417

418
419
420
421
422
423
424
...
909
910
911
912
913
914
915
916
917
918
919
920
921
922










923
924
925
926
927
928
929
$00FF0020 new-color: pet-color
$FFFF80FF new-color, fvalue users-color#
$FFCCCCFF new-color, fvalue gps-color#
$000077FF new-color, fvalue chain-color#
$FF000000 $FF0000FF fade-color: show-error-color
$338833FF text-color: lock-color
$883333FF text-color: lockout-color


: nick[] ( box o:nick -- box )
    [: data >o ." clicked on " ke-nick $. cr o> ;] o click[] ;

Hash: avatar#

glue new Constant glue*avatar
................................................................................
	    show-error-color 1e +to x-color l" locked out of chat" }}text' 25%bv
	}}z
    THEN "lock" name! msg-box .child+ ; wmsg-class is msg:lock
:noname ( -- o )
	{{
	    glue*l lock-color x-color slide-frame dup .button1
	    blackish l" chat is unlocked" }}text' 25%bv
	}}z msg-box .child+ ;
:noname { d: string -- o }
    {{
	glue*l gps-color# slide-frame dup .button1
	string [: ."  GPS: " .coords ;] $tmp }}text 25%b
    }}z "gps" name! msg-box .child+
; wmsg-class is msg:coord










:noname { d: string -- o }
    {{
	glue*l chain-color# slide-frame dup .button1
	string sighash? IF  re-green  ELSE  obj-red  THEN
	string [: ." <" drop le-64@ .ticks ;] $tmp }}text 25%b
    }}z "chain" name! msg-box .child+
; wmsg-class is msg:chain







>







 







|






>
>
>
>
>
>
>
>
>
>







411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
...
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
$00FF0020 new-color: pet-color
$FFFF80FF new-color, fvalue users-color#
$FFCCCCFF new-color, fvalue gps-color#
$000077FF new-color, fvalue chain-color#
$FF000000 $FF0000FF fade-color: show-error-color
$338833FF text-color: lock-color
$883333FF text-color: lockout-color
$FFAA44FF text-color, fvalue perm-color#

: nick[] ( box o:nick -- box )
    [: data >o ." clicked on " ke-nick $. cr o> ;] o click[] ;

Hash: avatar#

glue new Constant glue*avatar
................................................................................
	    show-error-color 1e +to x-color l" locked out of chat" }}text' 25%bv
	}}z
    THEN "lock" name! msg-box .child+ ; wmsg-class is msg:lock
:noname ( -- o )
	{{
	    glue*l lock-color x-color slide-frame dup .button1
	    blackish l" chat is unlocked" }}text' 25%bv
	}}z msg-box .child+ ; wmsg-class is msg:unlock
:noname { d: string -- o }
    {{
	glue*l gps-color# slide-frame dup .button1
	string [: ."  GPS: " .coords ;] $tmp }}text 25%b
    }}z "gps" name! msg-box .child+
; wmsg-class is msg:coord
:noname { 64^ perm d: pk -- }
    perm [ 1 64s ]L pk msg-group-o .msg:perms# #!
    {{
	glue*l perm-color# slide-frame dup .button1
	{{
	    pk [: '@' emit .key-id ;] $tmp ['] utf8-sanitize $tmp }}text 25%b
	    perm 64@ 64>n ['] .perms $tmp }}text 25%b
	}}h
    }}z msg-box .child+
; wmsg-class is msg:perms
:noname { d: string -- o }
    {{
	glue*l chain-color# slide-frame dup .button1
	string sighash? IF  re-green  ELSE  obj-red  THEN
	string [: ." <" drop le-64@ .ticks ;] $tmp }}text 25%b
    }}z "chain" name! msg-box .child+
; wmsg-class is msg:chain

Changes to msg.fs.

463
464
465
466
467
468
469
470
471
472
473
474



475
476
477
478
479
480
481
...
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
...
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
....
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
....
1202
1203
1204
1205
1206
1207
1208
1209



1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
....
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
	<info> ." chat is locked" <default>
    ELSE  2drop
	<err> ." locked out of chat" <default>
    THEN ; msg-class is msg:lock
:noname ( -- )  msg-group-o .msg:-lock
    <info> ." chat is free for all" <default> ; msg-class is msg:unlock
' drop msg-class is msg:away
:noname { 64^ perm d: pk -- }
    perm [ 1 64s ]L pk msg-group-o .msg:perms# #!
    pk .key-id ." : " perm 64@ 64>n s" 👹" bounds U+DO
	dup 1 and IF  I xc@ xemit  THEN  2/
    I I' over - x-size  +LOOP  drop space



; msg-class is msg:perms
:noname ( addr u type -- )
    space <warn> case
	msg:image#     of  ." img["      85type  endof
	msg:thumbnail# of  ." thumb["    85type  endof
	msg:patch#     of  ." patch["    85type  endof
	msg:snapshot#  of  ." snapshot[" 85type  endof
................................................................................

:noname ( -- )
    <info>
    [: ." nobody's online" msg-group-o .msg:?otr 0= IF ." , saving away"  THEN ;] $tmp
    2dup type <default>
    wait-2s-key xclear ; msg-class is msg:.nobody






















: replace-sig { addrsig usig addrmsg umsg -- }
    \ !!dummy!! need to verify signature!
    addrsig usig addrmsg umsg usig - [: type type ;] $tmp
    2dup pk-sig? !!sig!! 2drop addrmsg umsg smove ;
: new-otrsig ( addr u -- addrsig usig )
    2dup startdate@ old>otr



    c:0key sigpksize# - c:hash ['] .sig $tmp 1 64s /string ;

:noname { sig u' addr u -- }
    u' 64'+ u =  u sigsize# = and IF
	last# >r last# $@ >group
	addr u startdate@ 64dup date>i >r 64#1 64+ date>i' r>
	2dup = IF  ."  [otrified] "  addr u startdate@ .ticks  THEN
	U+DO
	    I msg-group-o .msg:log[] $[]@

	    2dup dup sigpksize# - /string key| msg:id$ str= IF
		dup u - /string addr u str= IF
		    ."  OTRify #" I u.
		    sig u' I msg-group-o .msg:log[] $[]@ replace-sig
		    save-msgs&
		ELSE
		    ."  [OTRified] #" I u.
................................................................................
net2o' nestsig net2o: msg-nestsig ( $:cmd+sig -- ) \g check sig+nest
    $> 2dup nest-sig ?dup-0=-IF
	handle-msg
    ELSE  replay-mode @ IF  drop 2drop 2drop
	ELSE  !!sig!!  THEN \ balk on all wrong signatures
    THEN ;

: msg-sig? ( addr u -- addr u' flag )
    skip-sig? @ IF   quicksig( pk-quick-sig? )else( pk-date? )
    ELSE  pk-sig?  THEN ;

\ encrypt+sign
\ features: signature verification only when key is known
\           identity only revealed when correctly decrypted

: msg-dec-sig? ( addr u -- addr' u' flag )
    sigpksize# - 2dup + { pksig }
    msg-group-o .msg:keys[] $@ bounds U+DO
	I $@ 2over pksig decrypt-sig?
	dup -5 <> IF
	    >r 2nip r> unloop  EXIT
	THEN  drop 2drop
    cell +LOOP
    sigpksize# +  -5 ;

: msg-dec?-sig? ( addr u -- addr' u' flag )
    2dup 2 - + c@ $80 and IF  msg-dec-sig?  ELSE  msg-sig?  THEN ;

\ generate an encryt+sign packet

: ]encpksign ( -- )
    +zero16 nest$
    0 msg-group-o .msg:keys[] $[]@ encrypt$
    ['] .encsign ']nestsig ;

................................................................................
    [: last# >r o IF  2dup do-msg-nestsig
      ELSE  2dup display-one-msg  THEN  r> to last#
      0 .avalanche-msg ;] [group] drop notify- ;

\ chat message, text only

: msg-tdisplay ( addr u -- )
    2dup 2 - + c@ $80 and IF  net2o-base:msg-dec-sig? IF
	    2drop <err> ." Undecryptable message" <default> cr  EXIT
	THEN  <info>  THEN
    sigpksize# - 2dup + sigpksize# >$  c-state off
    nest-cmd-loop msg:end <default> ;
' msg-tdisplay msg-class is msg:display
' msg-tdisplay msg-notify-class is msg:display
: ?search-lock ( addr u -- )
................................................................................
    ['] nick>chat arg-loop ;

\ do otrify

also net2o-base

: do-otrify ( n -- ) >r
    msg-group$ $@ >group msg-group-o .msg:log[] $@ r> cells safe/string



    IF  $@ 2dup + sigpksize# - sigpksize#
	over keysize pkc over str= IF
	    keysize /string 2swap new-otrsig 2swap
	    $, $, msg-otrify
	ELSE
	    2drop 2drop ." not your message!" forth:cr
	THEN
    THEN ;

previous

\ debugging aids for classes

: .ack ( o:ack -- o:ack )
    ." ack context:" cr
................................................................................

:noname ( addr u -- )
    ['] logstyles evaluate-in ; is /logstyle

:noname ( addr u -- )
    msg-group-o .msg:mode dup @ msg:otr# or swap
    [: now>otr
	[: BEGIN  bl $split 2>r dup  WHILE  s>unumber? WHILE
			drop do-otrify  2r>  REPEAT THEN
	    2drop 2r> 2drop
	;] (send-avalanche) drop .chat save-msgs&
    ;] !wrapper ; is /otrify

:noname ( addr u -- )
    msg-group-o .msg:-lock







|
<
|

|
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

<

|


>
>
>
|








>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







|
>
>
>
|
|





|







 







|







463
464
465
466
467
468
469
470

471
472
473
474
475
476
477
478
479
480
481
482
483
...
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
...
716
717
718
719
720
721
722





















723
724
725
726
727
728
729
....
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
....
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
....
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
	<info> ." chat is locked" <default>
    ELSE  2drop
	<err> ." locked out of chat" <default>
    THEN ; msg-class is msg:lock
:noname ( -- )  msg-group-o .msg:-lock
    <info> ." chat is free for all" <default> ; msg-class is msg:unlock
' drop msg-class is msg:away
: .perms ( n -- )

    "👹" bounds U+DO
	dup 1 and IF  I xc@ xemit  THEN  2/
    I I' over - x-size  +LOOP  drop ;
:noname { 64^ perm d: pk -- }
    perm [ 1 64s ]L pk msg-group-o .msg:perms# #!
    pk .key-id ." : " perm 64@ 64>n .perms space
; msg-class is msg:perms
:noname ( addr u type -- )
    space <warn> case
	msg:image#     of  ." img["      85type  endof
	msg:thumbnail# of  ." thumb["    85type  endof
	msg:patch#     of  ." patch["    85type  endof
	msg:snapshot#  of  ." snapshot[" 85type  endof
................................................................................

:noname ( -- )
    <info>
    [: ." nobody's online" msg-group-o .msg:?otr 0= IF ." , saving away"  THEN ;] $tmp
    2dup type <default>
    wait-2s-key xclear ; msg-class is msg:.nobody

\ encrypt+sign
\ features: signature verification only when key is known
\           identity only revealed when correctly decrypted

: msg-dec-sig? ( addr u -- addr' u' flag )
    sigpksize# - 2dup + { pksig }
    msg-group-o .msg:keys[] $@ bounds U+DO
	I $@ 2over pksig decrypt-sig?
	dup -5 <> IF
	    >r 2nip r> unloop  EXIT
	THEN  drop 2drop
    cell +LOOP
    sigpksize# +  -5 ;

: msg-sig? ( addr u -- addr u' flag )
    skip-sig? @ IF   quicksig( pk-quick-sig? )else( pk-date? )
    ELSE  pk-sig?  THEN ;

: msg-dec?-sig? ( addr u -- addr' u' flag )
    2dup 2 - + c@ $80 and IF  msg-dec-sig?  ELSE  msg-sig?  THEN ;

: replace-sig { addrsig usig addrmsg umsg -- }

    addrsig usig addrmsg umsg usig - [: type type ;] $tmp
    2dup msg-dec?-sig? !!sig!! 2drop addrmsg umsg smove ;
: new-otrsig ( addr u -- addrsig usig )
    2dup startdate@ old>otr
    predate-key keccak# c:key@ c:key# smove
    + 2 - c@ $80 and >r
    ['] .encsign-rest ['] .sig r> select
    $tmp 1 64s /string ;

:noname { sig u' addr u -- }
    u' 64'+ u =  u sigsize# = and IF
	last# >r last# $@ >group
	addr u startdate@ 64dup date>i >r 64#1 64+ date>i' r>
	2dup = IF  ."  [otrified] "  addr u startdate@ .ticks  THEN
	U+DO
	    I msg-group-o .msg:log[] $[]@
	    2dup + 2 - c@ $80 and IF  msg-dec-sig? drop  THEN
	    2dup dup sigpksize# - /string key| msg:id$ str= IF
		dup u - /string addr u str= IF
		    ."  OTRify #" I u.
		    sig u' I msg-group-o .msg:log[] $[]@ replace-sig
		    save-msgs&
		ELSE
		    ."  [OTRified] #" I u.
................................................................................
net2o' nestsig net2o: msg-nestsig ( $:cmd+sig -- ) \g check sig+nest
    $> 2dup nest-sig ?dup-0=-IF
	handle-msg
    ELSE  replay-mode @ IF  drop 2drop 2drop
	ELSE  !!sig!!  THEN \ balk on all wrong signatures
    THEN ;






















\ generate an encryt+sign packet

: ]encpksign ( -- )
    +zero16 nest$
    0 msg-group-o .msg:keys[] $[]@ encrypt$
    ['] .encsign ']nestsig ;

................................................................................
    [: last# >r o IF  2dup do-msg-nestsig
      ELSE  2dup display-one-msg  THEN  r> to last#
      0 .avalanche-msg ;] [group] drop notify- ;

\ chat message, text only

: msg-tdisplay ( addr u -- )
    2dup 2 - + c@ $80 and IF  msg-dec-sig? IF
	    2drop <err> ." Undecryptable message" <default> cr  EXIT
	THEN  <info>  THEN
    sigpksize# - 2dup + sigpksize# >$  c-state off
    nest-cmd-loop msg:end <default> ;
' msg-tdisplay msg-class is msg:display
' msg-tdisplay msg-notify-class is msg:display
: ?search-lock ( addr u -- )
................................................................................
    ['] nick>chat arg-loop ;

\ do otrify

also net2o-base

: do-otrify ( n -- ) >r
    msg-group$ $@ >group msg-group-o .msg:log[] $@
    r> cells dup 0< IF  over + 0 max  THEN safe/string
    IF  $@
	2dup + 2 - c@ $80 and IF  msg-dec-sig? drop  THEN
	2dup + sigpksize# - sigpksize#
	over keysize pk@ key| str= IF
	    keysize /string 2swap new-otrsig 2swap
	    $, $, msg-otrify
	ELSE
	    2drop 2drop ." not your message!" forth:cr
	THEN
    ELSE  drop  THEN ;

previous

\ debugging aids for classes

: .ack ( o:ack -- o:ack )
    ." ack context:" cr
................................................................................

:noname ( addr u -- )
    ['] logstyles evaluate-in ; is /logstyle

:noname ( addr u -- )
    msg-group-o .msg:mode dup @ msg:otr# or swap
    [: now>otr
	[: BEGIN  bl $split 2>r dup  WHILE  s>number? WHILE
			drop do-otrify  2r>  REPEAT THEN
	    2drop 2r> 2drop
	;] (send-avalanche) drop .chat save-msgs&
    ;] !wrapper ; is /otrify

:noname ( addr u -- )
    msg-group-o .msg:-lock