Try to make otrify work with encrypted messages — tricky, still doesn't work

crypt.fs

@@ -49,7 +49,9 @@ object uclass keytmp
     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
@@ -581,6 +583,7 @@ drop
     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
@@ -694,25 +697,29 @@ drop
 : 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 pktmp modkey>
 	    pksig sigpksize# keysize /string
-	    pktmp keysize
+	    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 ( -- )
-    +sig sigdate +date
-    sktmp pktmp sk@ drop >modkey
-    pktmp keysize type  sigdate datesize# type
-    sig-params 2drop sktmp pktmp ed-sign
+: .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:

gui.fs

@@ -415,6 +415,7 @@ $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[] ;
@@ -913,13 +914,23 @@ Variable emojis$ "👍👎🤣😍😘😛🤔😭😡😱🔃" emojis$ $! \
 	{{
 	    glue*l lock-color x-color slide-frame dup .button1
 	    blackish l" chat is unlocked" }}text' 25%bv
-	}}z msg-box .child+ ;
+	}}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

msg.fs

@@ -467,11 +467,13 @@ scope: logstyles
 :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 s" 👹" bounds U+DO
-	dup 1 and IF  I xc@ xemit  THEN  2/
-    I I' over - x-size  +LOOP  drop space
+    pk .key-id ." : " perm 64@ 64>n .perms space
 ; msg-class is msg:perms
 :noname ( addr u type -- )
     space <warn> case
@@ -504,13 +506,36 @@ msg-class is msg:object
     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 -- }
-    \ !!dummy!! need to verify signature!
     addrsig usig addrmsg umsg usig - [: type type ;] $tmp
-    2dup pk-sig? !!sig!! 2drop addrmsg umsg smove ;
+    2dup msg-dec?-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 ;
+    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
@@ -519,6 +544,7 @@ msg-class is msg:object
 	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.
@@ -694,27 +720,6 @@ net2o' nestsig net2o: msg-nestsig ( $:cmd+sig -- ) \g check sig+nest
 	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 ( -- )
@@ -1007,7 +1012,7 @@ previous
 \ chat message, text only
 
 : msg-tdisplay ( addr u -- )
-    2dup 2 - + c@ $80 and IF  net2o-base:msg-dec-sig? IF
+    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
@@ -1206,15 +1211,18 @@ Variable chat-keys
 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
+    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
-    THEN ;
+    ELSE  drop  THEN ;
 
 previous
 
@@ -1491,7 +1499,7 @@ is /help
 :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
+	[: 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&