$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)

    $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)

$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

$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

	<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

	<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