Artifact Content
Not logged in

Artifact 2ef536f349b27ab6b3566efd52c837ba2ad17c37:


\ messages                                           06aug2014py

\ Copyright (C) 2014-2016   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/>.

Forward avalanche-to ( addr u o:context -- )
Forward pk-connect ( key u cmdlen datalen -- )
Forward pk-connect? ( key u cmdlen datalen -- flag )
Forward addr-connect ( key+addr u cmdlen datalen xt -- )
Forward pk-peek? ( addr u0 -- flag )

: ?hash ( addr u hash -- ) >r
    2dup r@ #@ d0= IF  "" 2swap r> #!  ELSE  2drop rdrop  THEN ;

Variable otr-mode \ global otr mode

: >group ( addr u -- )
    2dup msg-group# #@ d0= IF
	net2o:new-msg >o 2dup to msg:name$
	otr-mode @ IF  msg:+otr  THEN
	o o>
	cell- [ msg-class >osize @ cell+ ]L
	2over msg-group# #!
    THEN  last# cell+ $@ drop cell+ to msg-group-o
    2drop ;

: avalanche-msg ( msg u1 o:connect -- )
    \G forward message to all next nodes of that message group
    { d: msgx }
    msg-group-o .msg:peers[] $@
    bounds ?DO  I @ o <> IF  msgx I @ .avalanche-to  THEN
    cell +LOOP ;

Variable msg-group$
User replay-mode
User skip-sig?

Sema msglog-sema

: ?msg-context ( -- o )
    msging-context @ dup 0= IF
	drop
	net2o:new-msging dup msging-context !
    THEN ;

: >chatid ( group u -- id u )  defaultkey sec@ keyed-hash#128 ;

: msg-log@ ( -- addr u )
    [: msg-group-o .msg:log[] $@ save-mem ;] msglog-sema c-section ;

: purge-log ( -- )
    [: msg-group-o .msg:log[] { a[] }
	0  BEGIN  dup a[] $[]# u<  WHILE
		dup a[] $[]@ check-date nip nip IF
		    dup a[] $[] $free
		    a[] over cells cell $del
		ELSE
		    1+
		THEN
	REPEAT  drop ;] msglog-sema c-section ;

: serialize-log ( addr u -- $addr )
    [: bounds ?DO
	    I $@ check-date 0= IF  net2o-base:$, net2o-base:nestsig
	    ELSE   msg( ." removed entry " dump )else( 2drop )  THEN
      cell +LOOP ;]
    gen-cmd ;

Variable saved-msg$
64Variable saved-msg-ticks

: save-msgs ( group-o -- ) to msg-group-o
    msg( ." Save messages in group " msg-group-o dup hex. .msg:name$ type cr )
    ?.net2o/chats  net2o:new-msging >o
    msg-log@ over >r  serialize-log enc-file $!buf
    r> free throw  dispose o>
    msg-group-o .msg:name$ >chatid .chats/ enc-filename $!
    pk-off  key-list encfile-rest ;

: save-all-msgs ( -- )
    saved-msg$ $@ bounds ?DO  I @ save-msgs  cell +LOOP
    saved-msg$ $free ;

: save-msgs? ( -- )
    saved-msg-ticks 64@ ticker 64@ 64u<= IF  save-all-msgs
	ticks config:savedelta& 2@ d>64 64+ saved-msg-ticks 64!  THEN ;

: next-saved-msg ( -- time )
    saved-msg-ticks 64@ 64dup 64#0 64= IF
	64drop ticks 64dup saved-msg-ticks 64!  THEN ;

: msg-eval ( addr u -- )
    net2o:new-msging >o 0 to parent do-cmd-loop dispose o> ;

: load-msg ( group u -- )  2dup >group
    >chatid .chats/ [: type ." .v2o" ;] $tmp
    2dup file-status nip no-file# = IF  2drop EXIT  THEN
    replay-mode on  skip-sig? on
    ['] decrypt@ catch
    ?dup-IF  DoError 2drop
	\ try read backup instead
	[: enc-filename $. '~' emit ;] $tmp ['] decrypt@ catch
	?dup-IF  DoError 2drop
	ELSE  msg-eval  THEN
    ELSE  msg-eval  THEN
    replay-mode off  skip-sig? off  enc-file $free ;

event: :>save-msgs ( group-o -- ) saved-msg$ +unique$ ;
event: :>save-all-msgs ( -- )
    save-all-msgs ;
event: :>load-msg ( group-o -- )
    .msg:name$ load-msg ;

: >load-group ( group u -- )
    >group msg-group-o .msg:log[] $@len 0=
    IF  <event msg-group-o elit, :>load-msg
	parent .wait-task @
	dup 0= IF  drop ?file-task  THEN  event>  THEN ;

: !save-all-msgs ( -- )
    syncfile( save-all-msgs )else(
    <event :>save-all-msgs ?file-task event| ) ;

: save-msgs& ( -- )
    syncfile( msg-group-o saved-msg$ +unique$ )else(
    <event msg-group-o elit, :>save-msgs ?file-task event> ) ;

0 Value log#
2Variable last-msg

: +msg-log ( addr u -- addr' u' / 0 0 )
    [: msg-group-o .msg:log[] $ins[]date  dup  dup 0< xor to log#
	log# msg-group-o .msg:log[] $[]@ last-msg 2!
	0< IF  #0.  ELSE  last-msg 2@  THEN
    ;] msglog-sema c-section ;
: ?save-msg ( -- )
    msg( ." saving messages in group " msg-group-o dup hex. .msg:name$ type cr )
    msg-group-o .msg:?otr replay-mode @ or 0= IF  save-msgs&  THEN ;

Sema queue-sema

\ peer queue, in msg context

: peer> ( -- addr / 0 )
    [: msg:peers[] back> ;] queue-sema c-section ;
: >peer ( addr u -- )
    [: msg:peers[] $+[]! ;] queue-sema c-section ;

\ events

msg-class class end-class msg-notify-class

msg-notify-class ' new static-a with-allocater Constant msg-notify-o

: >msg-log ( addr u -- addr' u )
    +msg-log ?save-msg ;

: do-msg-nestsig ( addr u -- )
    2dup msg-group-o .msg:display
    msg-notify-o .msg:display ;

: display-lastn ( n -- )
    msg-group-o .msg:redisplay ;
: display-sync-done ( -- )
    rows  msg-group-o .msg:redisplay ;

: display-one-msg { d: msgt -- }
    msg-group-o >o
    msgt ['] msg:display catch IF  ." invalid entry"  cr  2drop  THEN
    o> ;

Forward silent-join

\ !!FIXME!! should use an asynchronous "do-when-connected" thing

: +unique-con ( -- ) o msg-group-o .msg:peers[] +unique$ ;
Forward +chat-control

: chat-silent-join ( -- )
    reconnect( ." silent join " o hex. connection hex. cr )
    o to connection
    ?msg-context >o silent-last# @ to last# o>
    reconnect( ." join: " last# $. cr )
    +unique-con silent-join ;

: chat-silent-rqd ( n -- )
    reconnect( ." silent requst" cr )
    clean-request chat-silent-join ;

: ?nat ( -- )  o to connection
    net2o-code nat-punch end-code ;

: ?chat-nat ( -- )
    ['] chat-silent-rqd rqd! ?nat ;

: chat-rqd-nat ( n -- )
    reconnect( ." chat req done, start nat traversal" cr )
    connect-rest  +flow-control +resend ?chat-nat ;

: chat-rqd-nonat ( n -- )
    reconnect( ." chat req done, start silent join" cr )
    connect-rest  +flow-control +resend chat-silent-join ;

User peer-buf

: reconnect-chat ( addr u $chat -- )
    peer-buf $!buf  last# peer-buf $@
    reconnect( ." reconnect " 2dup 2dup + 1- c@ 1+ - .addr$ cr )
    reconnect( ." in group: " last# dup hex. $. cr )
    0 >o $A $A [: reconnect( ." prepare reconnection" cr )
      ?msg-context >o silent-last# ! o>
      ['] chat-rqd-nat ['] chat-rqd-nonat ind-addr @ select rqd! ;]
    addr-connect 2dup d0= IF  2drop  ELSE  avalanche-to  THEN o> ;

event: :>avalanche ( addr u o group -- )
    avalanche( ." Avalanche to: " dup hex. cr )
    to msg-group-o .avalanche-msg ;
event: :>chat-reconnect ( addr u $chat o group -- )
    to msg-group-o .reconnect-chat ;
event: :>msg-nestsig ( $addr o group -- )
    to msg-group-o >o { w^ m } m $@ do-msg-nestsig m $free o>
    ctrl L inskey ;

\ coordinates

6 sfloats buffer: coord"
90e coord" sfloat+ sf!
: coord@ ( -- addr u ) coord" 6 sfloats ;
: sf[]@ ( addr i -- sf )  sfloats + sf@ ;
: sf[]! ( addr i -- sf )  sfloats + sf! ;

[IFDEF] android
    require unix/jni-location.fs
    also android
    : coord! ( -- ) location ?dup-IF  >o
	    getLatitude  coord" 0 sf[]!
	    getLongitude coord" 1 sf[]!
	    getAltitude  coord" 2 sf[]!
	    getSpeed     coord" 3 sf[]!
	    getBearing   coord" 4 sf[]!
	    getAccuracy  coord" 5 sf[]!
	    o>
	ELSE
	    start-gps
	THEN ;
    :noname level# @ 0> IF  -1 level# +!
	ELSE  ctrl U inskey ctrl D inskey THEN ; is aback
    previous
[ELSE]
    [IFDEF] has-gpsd?
	s" unix/gpslib.fs" ' required catch [IF]
	    2drop : coord! ;
	[ELSE]
	    0 Value gps-opened?
	    : coord! ( -- ) gps-opened? 0= IF
		    gps-local-open 0= to gps-opened?
		    gps-opened? 0= ?EXIT
		THEN
		gps-fix { fix }
		fix gps:gps_fix_t-latitude  df@ coord" 0 sf[]!
		fix gps:gps_fix_t-longitude df@ coord" 1 sf[]!
		fix gps:gps_fix_t-altitude  df@ coord" 2 sf[]!
		fix gps:gps_fix_t-speed     df@ coord" 3 sf[]!
		fix gps:gps_fix_t-track     df@ coord" 4 sf[]!
		fix gps:gps_fix_t-epx df@ f**2
		fix gps:gps_fix_t-epy df@ f**2
		f+ fsqrt                        coord" 5 sf[]! ;
	[THEN]
    [ELSE]
	: coord! ( -- ) ;
    [THEN]
[THEN]

: .coords ( addr u -- ) $>align drop
    dup 0 sf[]@ fdup fabs .deg f0< 'S' 'N' rot select emit space
    dup 1 sf[]@ fdup fabs .deg f0< 'W' 'E' rot select emit space
    dup 2 sf[]@ 7 1 0 f.rdp ." m "
    dup 3 sf[]@ 8 2 0 f.rdp ." km/h "
    dup 4 sf[]@ 8 2 0 f.rdp ." ° ~"
    dup 5 sf[]@ fsplit 0 .r '.' emit 100e f* f>s .## ." m"
    drop ;

Forward msg:last?
Forward msg:last

: push-msg ( addr u o:parent -- )
    up@ receiver-task <> IF
	avalanche-msg
    ELSE wait-task @ ?dup-IF
	    <event >r e$, o elit, msg-group-o elit,
	    :>avalanche r> event>
	ELSE  2drop  THEN
    THEN ;
: show-msg ( addr u -- )
    parent dup IF  .wait-task @ dup up@ <> and  THEN
    ?dup-IF
	>r r@ <hide> <event $make elit, o elit, msg-group-o elit, :>msg-nestsig
	r> event>
    ELSE  do-msg-nestsig  THEN ;

: date>i ( date -- i )
    msg-group-o .msg:log[] $search[]date msg-group-o .msg:log[] $[]# 1- umin ;
: date>i' ( date -- i )
    msg-group-o .msg:log[] $search[]date msg-group-o .msg:log[] $[]# umin ;
: sighash? ( addr u -- flag )
    over le-64@ date>i
    dup 0< IF  drop 2drop  false  EXIT  THEN  >r
    over le-64@ 64#1 64+ date>i' >r [ 1 64s ]L /string
    r> r> U+DO
	c:0key I msg-group-o .msg:log[] $[]@ sigonly@ >hash
	2dup hashtmp over str= IF  2drop true  UNLOOP   EXIT
	ELSE  ( 2dup 85type ."  <> " hashtmp over 85type )  THEN
    LOOP
    2drop false ;

: msg-key! ( addr u -- )
    0 msg-group-o .msg:keys[] [: rot >r 2over str= r> or ;] $[]map
    IF  2drop  ELSE  \ ." msg-key+ " 2dup 85type forth:cr
	$make msg-group-o .msg:keys[] >back  THEN ;

\ message commands

scope{ net2o-base

\g 
\g ### message commands ###
\g 

reply-table $@ inherit-table msg-table

$20 net2o: msg-start ( $:pksig -- ) \g start message
    1 !!>order? $> msg:start ;
+net2o: msg-tag ( $:tag -- ) \g tagging (can be anywhere)
    $> msg:tag ;
+net2o: msg-id ( $:id -- ) \g a hash id
    2 !!>=order? $> msg:id ;
+net2o: msg-chain ( $:dates,sighash -- ) \g chained to message[s]
    ( $10 !!>=order? ) $> msg:chain ;
+net2o: msg-signal ( $:pubkey -- ) \g signal message to one person
    $> msg:signal ;
+net2o: msg-re ( $:hash ) \g relate to some object
    4 !!>=order? $> msg:re ;
+net2o: msg-text ( $:msg -- ) \g specify message string
    8 !!>=order? $> msg:text ;
+net2o: msg-object ( $:object type -- ) \g specify an object, e.g. an image
    8 !!>=order? 64>n $> rot msg:object ;
+net2o: msg-action ( $:msg -- ) \g specify action string
    8 !!>=order? $> msg:action ;
+net2o: msg-payment ( $:contract -- ) \g payment transaction
    8 !!>=order? $> msg:payment ;
+net2o: msg-otrify ( $:date+sig $:newdate+sig -- ) \g turn a past message into OTR
    $> $> msg:otrify ;
+net2o: msg-coord ( $:gps -- ) \g GPS coordinates
    8 !!>=order? $> msg:coord ;
+net2o: msg-url ( $:url -- ) \g specify message URL
    $> msg:url ;
+net2o: msg-like ( xchar -- ) \g add a like
    64>n msg:like ;
+net2o: msg-lock ( $:key -- ) \g lock down communciation
    $> msg:lock ;
+net2o: msg-unlock ( -- ) \g unlock communication
    msg:unlock ;
+net2o: msg-perms ( $:pk perm -- ) \g permissions
    $> msg:perms ;
}scope

msg-table $save

' context-table is gen-table

\ Code for displaying messages

Defer .log-num
Defer .log-date
Defer .log-end

: .otr-info ( -- )
    <info> ." [otr] " <default> "[otr] " notify+ notify-otr? on ;
: .otr-err ( -- )
    <err> ." [exp] " <default> 1 notify-otr? ! ;
: .otr ( tick -- )
    64dup 64#-1 64= IF  64drop  notify-otr? off  EXIT  THEN
    ticks 64- 64dup fuzzedtime# 64negate 64< IF  64drop .otr-err  EXIT  THEN
    otrsig-delta# fuzzedtime# 64+ 64< IF  .otr-info  THEN ;
: .group ( addr u -- )
    2dup printable? IF  forth:type  ELSE  ." @" .key-id  THEN ;

scope: logstyles
: +num [: '#' emit log# u. ;] is .log-num ;
: -num ['] noop is .log-num ;
: +date [: .ticks space ;] is .log-date ;
: -date ['] 64drop is .log-date ;
: +end [: 64dup .ticks space .otr ;] is .log-end ;
: -end ['] .otr is .log-end ;

+date -num -end
}scope

:noname ( addr u -- )
    last# >r  2dup key| to msg:id$
    [: .simple-id ." : " ;] $tmp notify-nick!
    r> to last# ; msg-notify-class is msg:start
:noname ( addr u -- ) "#" notify+ $utf8> notify+
; msg-notify-class is msg:tag
:noname ( addr u -- )
    2dup [: ." @" .simple-id ;] $tmp notify+ ; msg-notify-class is msg:signal
:noname ( addr u -- ) $utf8> notify+ ; msg-notify-class is msg:text
:noname ( addr u -- ) $utf8> notify+ ; msg-notify-class is msg:url
:noname ( addr u -- ) $utf8> notify+ ; msg-notify-class is msg:action
' drop  msg-notify-class is msg:like
' 2drop  msg-notify-class is msg:lock
' noop  msg-notify-class is msg:unlock
:noname 2drop 64drop ; msg-notify-class is msg:perms
' drop  msg-notify-class is msg:away
' 2drop msg-notify-class is msg:coord
:noname 2drop 2drop ; msg-notify-class is msg:otrify
:noname ( -- ) msg-notify ; msg-notify-class is msg:end
:noname ( xchar -- ) ['] xemit $tmp notify+ ; msg-notify-class is msg:like

:noname ( addr u -- )
    last# >r  2dup key| to msg:id$
    .log-num
    2dup startdate@ .log-date
    2dup enddate@ .log-end
    .key-id ." : " 
    r> to last# ; msg-class is msg:start
:noname ( addr u -- ) $utf8>
    <warn> '#' forth:emit .group <default> ; msg-class is msg:tag
:noname ( addr u -- ) last# >r
    key| 2dup 0 .pk@ key| str=
    IF   <err>  THEN ." @" .key-id? <default>
    r> to last# ; msg-class is msg:signal
:noname ( addr u -- )
    last# >r last# $@ >group
    2dup sighash? IF  <info>  ELSE  <err>  THEN
    ."  <" over le-64@ .ticks
    verbose( dup keysize - /string ." ," 85type )else( 2drop ) <default>
    r> to last# ; msg-class is msg:chain
:noname ( addr u -- )
    space <warn> ." [" 85type ." ]->" <default> ; msg-class is msg:re
:noname ( addr u -- )
    space <warn> ." [" 85type ." ]:" <default> ; msg-class is msg:id
:noname ( addr u -- ) $utf8> forth:type ; msg-class is msg:text
:noname ( addr u -- ) $utf8>
    <warn> forth:type <default> ; msg-class is msg:url
:noname ( xchar -- )
    <info> utf8emit <default> ; msg-class is msg:like
:noname ( addr u -- )
    0 .v-dec$ dup IF
	msg-key!  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
	msg:message#   of  ." message["  85type  endof
	drop
	2dup keysize /string
	2dup printable? IF  '[' emit  type '@' emit
	ELSE  ." #["  85type ." /@"  THEN
	key| .key-id
	0
    endcase ." ]" <default> ;
msg-class is msg:object
:noname ( addr u -- ) $utf8>
    <warn> forth:type <default> ; msg-class is msg:action
:noname ( addr u -- )
    <warn> ."  GPS: " .coords <default> ; msg-class is msg:coord

: wait-2s-key ( -- )
    ntime 50 0 DO  key? ?LEAVE
    2dup i #40000000 um* d+ deadline  LOOP  2drop ;
: xclear ( addr u -- ) x-width 1+ x-erase ;

: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 flag -- addrsig usig )
    >r 2dup startdate@ old>otr
    predate-key keccak# c:key@ c:key# smove
    [: sktmp pkmod sk@ drop >modkey .encsign-rest ;]
    ['] .sig r@ select $tmp
    2dup + 2 - r> swap orc!
    ( 2dup dump ) 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.
		THEN
	    ELSE
		."  ID mismatch: "
		2dup dup sigpksize# - /string key| 85type space
		msg:id$ 85type forth:cr
		2drop
	    THEN
	LOOP
	r> to last#
    THEN ; msg-class is msg:otrify

:noname ( -- )
    forth:cr ; msg-class is msg:end

\g 
\g ### group description commands ###
\g 

hash: group#

static-a to allocater
align here
groups-class new Constant group-o
dynamic-a to allocater
here over - 2Constant sample-group$

: last>o ( -- )
    \G use last hash access as object
    last# cell+ $@ drop cell+ >o rdrop ;

: make-group ( addr u -- o:group )
    sample-group$ 2over group# #! last>o to groups:id$ ;

cmd-table $@ inherit-table group-table

scope{ net2o-base

$20 net2o: group-name ( $:name -- ) \g group symbolic name
    $> make-group ;
+net2o: group-id ( $:group -- ) \g group id, is a pubkey
    group-o o = !!no-group-name!! $> to groups:id$ ;
+net2o: group-member ( $:memberkey -- ) \g add member key
    group-o o = !!no-group-name!! $> groups:member[] $+[]! ;
+net2o: group-admin ( $:adminkey -- ) \g set admin key
    group-o o = !!no-group-name!! $> groups:admin sec! ;
+net2o: group-perms ( 64u -- ) \g permission/modes bitmask
    group-o o = !!no-group-name!! to groups:perms# ;

}scope

group-table $save

group-table @ group-o .token-table !

' context-table is gen-table

: .chats/group ( -- addr u )
    pk@ pkc swap move  sk@ skc swap move \ normalize pkc
    pkc keysize 3 * \ hash of pkc+pk1+skc keyed with "group"
    "group" keyed-hash#128 .chats/ ;

: read-chatgroups ( -- )
    0 ..chats/group [: type ." .v2o" ;] $tmp
    2dup file-status nip no-file# = IF  2drop  EXIT  THEN
    decrypt@ group-o .do-cmd-loop  enc-file $free ;

also net2o-base

: serialize-chatgroup ( last# -- )
    dup $@ 2dup $, group-name
    rot cell+ $@ drop cell+ >o
    groups:id$ dup IF
	2tuck str= 0= IF  $, group-id  ELSE  2drop  THEN
    ELSE  2drop 2drop  THEN
    groups:member[] [: $, group-member ;] $[]map
    groups:admin sec@ dup IF  sec$, group-admin  ELSE  2drop  THEN
    groups:perms# 64dup 64-0<> IF  lit, group-perms  ELSE  64drop  THEN
    o> ;

previous

: admin>pk ( -- )
    groups:admin sec@ drop dup sk-mask
    keysize addr groups:id$ $!len
    groups:id$ drop sk>pk ;

: gen-admin-key ( -- )
    $20 rng$ groups:admin sec! admin>pk ;

: save-chatgroups ( -- )
    0 ..chats/group enc-filename $!
    [: group# ['] serialize-chatgroup #map ;] gen-cmd enc-file $!buf
    pk-off  key-list encfile-rest ;

Variable group-list[]
: $ins[]group ( o:group $array -- pos )
    \G insert O(log(n)) into pre-sorted array
    \G @var{pos} is the insertion offset or -1 if not inserted
    { a[] } 0 a[] $[]#
    BEGIN  2dup u<  WHILE  2dup + 2/ { left right $# }
	    o $@ $# a[] $[] @ $@ compare dup 0= IF
		drop o cell+ $@ drop cell+ .groups:id$
		$# a[] $[] @ cell+ $@ drop cell+ .groups:id$ compare  THEN
	    0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
    o { w^ ins$0 } ins$0 cell a[] r@ cells $ins r> ;
: groups>sort[] ( -- )  group-list[] $free
    group# [: >o group-list[] $ins[]group o> drop ;] #map ;

: .chatgroup ( last# -- )
    dup $. space dup $@ rot cell+ $@ drop cell+ >o
    groups:id$ 2tuck str=
    IF  ." =" 2drop
    ELSE  ''' emit <info> 85type <default> ''' emit THEN space
    groups:member[] [: '@' emit .simple-id space ;] $[]map
\    ." admin " groups:admin[] [: '@' emit .simple-id space ;] $[]map
    ." +" groups:perms# x64.
    o> cr ;
: .chatgroups ( -- )
    groups>sort[]
    group-list[] $@ bounds ?DO  I @ .chatgroup  cell +LOOP ;

: ?pkgroup ( addr u -- addr u )
    \ if no group has been selected, use the pubkey as group
    last# 0= IF  2dup + sigpksize# - keysize >group  THEN ;

: handle-msg ( addr-o u-o addr-dec u-dec -- )
    ?pkgroup 2swap >msg-log
    2dup d0<> replay-mode @ 0= and \ do something if it is new
    IF
	2over show-msg
	2dup parent .push-msg
    THEN  2drop 2drop ;

\g 
\g ### messaging commands ###
\g 

scope{ net2o-base

$34 net2o: message ( -- o:msg ) \g push a message object
    perm-mask @ perm%msg and 0= !!msg-perm!!
    ?msg-context n:>o c-state off  0 to last# ;

msging-table >table

reply-table $@ inherit-table msging-table

$21 net2o: msg-group ( $:group -- ) \g set group
    $> >group ;
+net2o: msg-join ( $:group -- ) \g join a chat group
    $> >load-group parent >o
    +unique-con +chat-control
    wait-task @ ?dup-IF  <hide>  THEN
    o> ;
+net2o: msg-leave ( $:group -- ) \g leave a chat group
    $> >group parent msg-group-o .msg:peers[] del$cell ;
+net2o: msg-reconnect ( $:pubkey+addr -- ) \g rewire distribution tree
    $> $make
    <event last-msg 2@ e$, elit, o elit, msg-group-o elit, :>chat-reconnect
    parent .wait-task @ ?query-task over select event> ;
+net2o: msg-last? ( start end n -- ) 64>n msg:last? ;
+net2o: msg-last ( $:[tick0,msgs,..tickn] n -- ) 64>n msg:last ;

net2o' nestsig net2o: msg-nestsig ( $:cmd+sig -- ) \g check sig+nest
    $> nest-sig ?dup-0=-IF
	handle-msg
    ELSE  replay-mode @ IF  drop  ELSE  !!sig!!  THEN
	2drop 2drop \ balk on all wrong signatures
    THEN ;

\ generate an encryt+sign packet

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

\ nest-sig for msg/msging classes

' message msging-class is start-req
:noname check-date >r 2dup r> ; msging-class is nest-sig
' message msg-class is start-req
:noname 2dup msg-dec?-sig? ; msg-class is nest-sig

' context-table is gen-table

also }scope

msging-table $save

: msg-reply ( tag -- )
    ." got reply " hex. pubkey $@ key>nick forth:type forth:cr ;
: expect-msg ( o:connection -- )
    reply( ['] msg-reply )else( ['] drop ) expect-reply-xt +chat-control ;

User hashtmp$  hashtmp$ off

: last-msg@ ( -- ticks )
    last# >r
    last# $@ >group msg-group-o .msg:log[] $[]# ?dup-IF
	1- msg-group-o .msg:log[] $[]@ startdate@
    ELSE  64#0  THEN   r> to last# ;
: l.hashs ( end start -- hashaddr u )
    hashtmp$ $off
    msg-group-o .msg:log[] $[]# IF
	[: U+DO  I msg-group-o .msg:log[] $[]@ 1- dup 1 64s - safe/string forth:type
	  LOOP ;] hashtmp$ $exec hashtmp$ $@
	\ [: 2dup dump ;] stderr outfile-execute \ dump hash inputs
    ELSE  2drop s" "  THEN \ we have nothing yet
    >file-hash 1 64s umin ;
: i.date ( i -- )
    msg-group-o .msg:log[] $[]@ startdate@ 64#0 { 64^ x }
    x le-64! x 1 64s forth:type ;
: i.date+1 ( i -- )
    msg-group-o .msg:log[] $[]@ startdate@ 64#0 { 64^ x }
    64#1 64+ x le-64! x 1 64s forth:type ;
: last-msgs@ ( startdate enddate n -- addr u n' )
    \G print n intervals for messages from startdate to enddate
    \G The intervals contain the same size of messages except the
    \G last one, which may contain less (rounding down).
    \G Each interval contains a 64 bit hash of the last 64 bit of
    \G each message within the interval
    last# >r >r last# $@ >group purge-log
    msg-group-o .msg:log[] $[]#
    IF
	date>i' >r date>i' r> swap
	2dup - r> over >r 1- 1 max / 0 max 1+ -rot
	[: over >r U+DO  I i.date
	      dup I + I' umin I l.hashs forth:type
	  dup +LOOP
	  r> dup msg-group-o .msg:log[] $[]# u< IF  i.date
	  ELSE  1- i.date+1  THEN
	  drop ;] $tmp r> \ over 1 64s u> -
    ELSE  rdrop 64drop 64drop s" "  0 THEN   r> to last# ;

\ sync chatlog through virtual file access

termserver-class class
end-class msgfs-class

file-classes# Constant msgfs-class#
msgfs-class +file-classes

: save-to-msg ( addr u n -- )
    state-addr >o  msgfs-class# fs-class! w/o fs-create o> ;
: .chat-file ( addr u -- )
    over le-64@ .ticks 1 64s /string  ." ->"
    over le-64@ .ticks 1 64s /string  ." @"
    .group ;
in net2o : copy-msg ( filename u -- )
    ." copy msg: " 2dup .chat-file forth:cr
    [: msgfs-class# ulit, file-type 2dup $, r/o ulit, open-sized-file
      file-reg# @ save-to-msg ;] n2o>file
    1 file-count +! ;

$20 Value max-last#
$20 Value ask-last#

Variable ask-msg-files[]

: msg:last? ( start end n -- )
    last# $@ $, msg-group
    max-last# umin
    last-msgs@ >r $, r> ulit, msg-last ;
: ?ask-msg-files ( addr u -- )
    64#-1 64#0 { 64^ startd 64^ endd } \ byte order of 0 and -1 don't matter
    last# $@ >group
    $> bounds ?DO
	I' I 64'+ u> IF
	    I le-64@ date>i'
	    I 64'+ 64'+ le-64@ date>i' swap
	    l.hashs drop le-64@
	    I 64'+ le-64@ 64<> IF
		I 64@ startd le-64@ 64umin
		I 64'+ 64'+ 64@ endd le-64@ 64umax
	    ELSE
		startd le-64@ 64#-1 64<> IF
		    endd startd [: 1 64s forth:type 1 64s forth:type last# $. ;]
		    ask-msg-files[] dup $[]# swap $[] $exec
		THEN
		64#-1 64#0
	    THEN  endd le-64! startd le-64!
	THEN
    2 64s +LOOP
    startd le-64@ 64#-1 64<> IF
	endd startd [: 1 64s forth:type 1 64s forth:type last# $. ;]
	ask-msg-files[] dup $[]# swap $[] $exec
    THEN ;
: msg:last ( $:[tick0,tick1,...,tickn] n -- )
    last# >r  ask-msg-files[] $[]off
    forth:. ." Messages:" forth:cr
    ?ask-msg-files ask-msg-files[] $[]# IF
	parent >o  expect+slurp
	cmdbuf# @ 0= IF  $10 blocksize! $1 blockalign!  THEN
	ask-msg-files[] ['] net2o:copy-msg $[]map o>
    ELSE
	." === nothing to sync ===" forth:cr
	parent .sync-none-xt \ sync-nothing-xt???
    THEN
    r> to last# ;

:noname ( -- 64len )
    \ poll serializes the 
    fs-outbuf $off
    fs-path $@ 2 64s /string >group
    msg-log@ over >r
    fs-path $@ drop le-64@ date>i \ start index
    fs-path $@ drop 64'+ le-64@ 64#1 64+ date>i' \ end index
    over - >r
    cells safe/string r> cells umin
    req? @ >r req? off  serialize-log   r> req? !  fs-outbuf $!buf
    r> free throw
    fs-outbuf $@len u>64 ; msgfs-class is fs-poll
:noname ( addr u mode -- )
    \G addr u is starttick endtick name concatenated together
    fs-close drop fs-path $!  fs-poll fs-size!
    ['] noop is file-xt
; msgfs-class is fs-open

\ syncing done
: chat-sync-done ( group-addr u -- )
    msg( ." chat-sync-done " 2dup forth:type forth:cr )
    >group display-sync-done !save-all-msgs
    net2o-code expect-msg close-all net2o:gen-reset end-code
    net2o:close-all
    ." === sync done ===" forth:cr sync-done-xt ;
event: :>msg-eval ( parent $pack $addr -- )
    { w^ buf w^ group }
    group $@ 2 64s /string { d: gname }
    gname >group
    msg-group-o .msg:log[] $[]# u.
    buf $@ true replay-mode ['] msg-eval !wrapper
    buf $free ?save-msg
    group $@ .chat-file ."  saved "
    msg-group-o .msg:log[] $[]# u. forth:cr
    >o -1 file-count +!@ 1 =
    IF  gname chat-sync-done  THEN  group $free
    o> ;
: msg-file-done ( -- )
    fs-path $@len IF
	msg( ." msg file done: " fs-path $@ .chat-file forth:cr )
	['] fs-flush file-sema c-section
    THEN ;
:noname ( addr u mode -- )
    fs-close drop fs-path $!
    ['] msg-file-done is file-xt
; msgfs-class is fs-create
:noname ( addr u -- u )
    [ termserver-class :: fs-read ]
; msgfs-class is fs-read
:noname ( -- )
	<event parent elit, 0 fs-inbuf !@ elit,  0 fs-path !@ elit, :>msg-eval
	parent .wait-task @ event>
	fs:fs-clear
; msgfs-class is fs-flush    
:noname ( -- )
    fs-path @ 0= ?EXIT
    fs-inbuf $@len IF
	msg( ." Closing file " fs-path $@ .chat-file forth:cr )
	fs-flush
    THEN
; msgfs-class is fs-close
:noname ( perm -- )
    perm%msg and 0= !!msg-perm!!
; msgfs-class is fs-perm?
:noname ( -- date perm )
    64#0 0 ; msgfs-class is fs-get-stat
:noname ( date perm -- )
    drop 64drop ; msgfs-class is fs-set-stat
' file-start-req msgfs-class is start-req

\ message composer

: group, ( addr u -- )
    $, msg-group ;
: <msg ( -- )
    sign[ msg-group-o .msg:?lock IF  +zero16  THEN ;

: msg> ( -- )
    \G end a message block by adding a signature
    msg-group-o .msg:?lock IF  ]encpksign  ELSE  ]pksign  THEN ;
: msg-otr> ( -- )
    \G end a message block by adding a short-time signature
    now>otr msg> ;
: msg-log, ( -- addr u )
    last-signed 2@ >msg-log ;

previous

: ?destpk ( addr u -- addr' u' )
    2dup connection .pubkey $@ key| str= IF  2drop pk@ key|  THEN ;

: last-signdate@ ( -- 64date )
    msg-group-o .msg:log[] $@ dup IF
	+ cell- $@ startdate@ 64#1 64+
    ELSE  2drop 64#-1  THEN ;

also net2o-base
: [msg,] ( xt -- )  last# >r
    msg-group$ $@ dup IF  message ?destpk 2dup >group $,
	execute  end-with
    ELSE  2drop drop  THEN  r> to last# ;

: last, ( -- )
    64#0 64#-1 ask-last# last-msgs@ >r $, r> ulit, msg-last ;

: last?, ( -- )
    last-signdate@ { 64: date }
    64#0 lit, date lit, ask-last# ulit, msg-last?
    date 64#-1 64<> IF
	date lit, 64#-1 lit, 1 ulit, msg-last?
    THEN ;

: sync-ahead?, ( -- )
    last-signdate@ 64#1 64+ lit, 64#-1 lit, ask-last# ulit, msg-last? ;

: join, ( -- )
    [: msg-join sync-ahead?,
      <msg msg-start "joined" $, msg-action msg-otr> ;] [msg,] ;

: silent-join, ( -- )
    msg-group$ $@ dup IF  message $, msg-join  end-with
    ELSE  2drop  THEN ;

: leave, ( -- )
    [: msg-leave
      <msg msg-start "left" $, msg-action msg-otr> ;] [msg,] ;

: silent-leave, ( -- )
    ['] msg-leave [msg,] ;

: left, ( addr u -- )
    key| $, msg-signal "left (timeout)" $, msg-action ;
previous

: send-join ( -- )
    net2o-code expect-msg join,
    ( cookie+request ) end-code| ;

: silent-join ( -- )
    net2o-code expect-msg silent-join,
    end-code ;

: send-leave ( -- )
    connection .data-rmap IF  net2o-code expect-msg leave, end-code|  THEN ;
: send-silent-leave ( -- )
    connection .data-rmap IF  net2o-code expect-msg silent-leave, end-code|  THEN ;

: [group] ( xt -- flag )
    msg-group-o .msg:peers[] $@len IF
	msg-group-o .execute true
    ELSE
	0 .execute false
    THEN ;
: .chat ( addr u -- )
    [: 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 -- )
    BEGIN  dup  WHILE  cell- 2dup + $@ sigpksize# - 1- + c@ $2E = IF
		2dup + $@ ['] msg:display catch IF  2drop  THEN
		msg-group-o .msg:keys[] $[]# IF  drop 0  THEN
	    THEN
    REPEAT  2drop ;
: msg-tredisplay ( n -- )
    reset-time
    msg-group-o >o msg:?otr msg:-otr o> >r
    [:  cells >r msg-log@
	{ log u } u r> - 0 max { u' }  log u' ?search-lock
	log u u' /string bounds ?DO
	    I log - cell/ to log#
	    I $@ { d: msgt }
	    msgt ['] msg:display catch IF  ." invalid entry" cr
		2drop  THEN
	cell +LOOP
	log free throw ;] catch
    r> IF  msg-group-o .msg:+otr  THEN  throw ;
' msg-tredisplay msg-class is msg:redisplay

msg-class class
end-class textmsg-class

' 2drop textmsg-class is msg:start
:noname '#' emit type ; textmsg-class is msg:tag
:noname '@' emit .simple-id ; textmsg-class is msg:signal
' 2drop textmsg-class is msg:re
' 2drop textmsg-class is msg:chain
' type textmsg-class is msg:text
:noname drop 2drop ; textmsg-class is msg:object
:noname ." /me " type ; textmsg-class is msg:action
:noname ." /here " 2drop ; textmsg-class is msg:coord
' noop textmsg-class is msg:end

textmsg-class ' new static-a with-allocater Constant textmsg-o
msg-notify-o >o msg-table @ token-table ! o>
textmsg-o >o msg-table @ token-table ! o>

\ chat history browsing

64Variable line-date 64#-1 line-date 64!
Variable $lastline

: !date ( addr u -- addr u )
    2dup + sigsize# - le-64@ line-date 64! ;
: find-prev-chatline { maxlen addr -- max span addr span }
    msg-group$ $@ >group
    msg-group-o .msg:log[] $[]# 0= IF  maxlen 0 addr over  EXIT  THEN
    line-date 64@ date>i'
    BEGIN  1- dup 0>= WHILE  dup msg-group-o .msg:log[] $[]@
	dup sigpksize# - /string key| pk@ key| str=  UNTIL  THEN
    msg-group-o .msg:log[] $[]@ dup 0= IF  nip
    ELSE  !date ['] msg:display textmsg-o .$tmp 
	dup maxlen u> IF  dup >r maxlen 0 addr over r> grow-tib
	    2drop to addr drop to maxlen  THEN
	tuck addr maxlen smove
    THEN
    maxlen swap addr over ;
: find-next-chatline { maxlen addr -- max span addr span }
    msg-group$ $@ >group
    line-date 64@ date>i
    BEGIN  1+ dup msg-group-o .msg:log[] $[]# u< WHILE  dup msg-group-o .msg:log[] $[]@
	dup sigpksize# - /string key| pk@ key| str=  UNTIL  THEN
    dup msg-group-o .msg:log[] $[]# u>=
    IF    drop $lastline $@  64#-1 line-date 64!
    ELSE  msg-group-o .msg:log[] $[]@ !date ['] msg:display textmsg-o .$tmp  THEN
    dup maxlen u> IF  dup >r maxlen 0 addr over r> grow-tib
	2drop to addr drop to maxlen  THEN
    tuck addr maxlen smove
    maxlen swap addr over ;

: chat-prev-line  ( max span addr pos1 -- max span addr pos2 false )
    line-date 64@ 64#-1 64= IF
	>r 2dup swap $lastline $! r>  THEN
    clear-line find-prev-chatline
    edit-update false ;
: chat-next-line  ( max span addr pos1 -- max span addr pos2 false )
    line-date 64@ 64#-1 64= IF  false  EXIT  THEN
    clear-line find-next-chatline
    edit-update false ;
: chat-enter ( max span addr pos1 -- max span addr pos2 true )
    drop over edit-update true 64#-1 line-date 64! ;

edit-terminal-c class
end-class chat-terminal-c
chat-terminal-c ' new static-a with-allocater Constant chat-terminal

bl cells buffer: chat-ctrlkeys
xchar-ctrlkeys chat-ctrlkeys bl cells move

chat-terminal edit-out !

' chat-ctrlkeys is ctrlkeys

' chat-next-line ctrl N bindkey
' chat-prev-line ctrl P bindkey
' chat-enter     #lf    bindkey
' chat-enter     #cr    bindkey
\ :noname #tab (xins) 0 ; #tab   bindkey
[IFDEF] ebindkey
    keycode-limit keycode-start - cells buffer: chat-ekeys
    std-ekeys chat-ekeys keycode-limit keycode-start - cells move
    
    ' chat-ekeys is ekeys
    
    ' chat-next-line k-down  ebindkey
    ' chat-prev-line k-up    ebindkey
    ' chat-next-line k-next  ebindkey
    ' chat-prev-line k-prior ebindkey
[THEN]

edit-terminal edit-out !

: chat-history ( -- )
    chat-terminal edit-out ! ;

\ chat line editor

$200 Constant maxmsg#

: get-input-line ( -- addr u )
    BEGIN  pad maxmsg# ['] accept catch
	dup dup -56 = swap -28 = or \ quit or ^c to leave
	IF    drop 2drop "/bye"
	ELSE
	    dup 0= IF
		drop pad swap 2dup xclear
	    ELSE
		DoError drop 0  THEN
	THEN
	dup 0= WHILE  2drop  REPEAT ;

\ joining and leaving

: g?join ( -- )
    msg-group$ $@len IF  send-join -timeout  THEN ;

: g?leave ( -- )
    msg-group$ $@len IF  send-leave -timeout  THEN ;

: greet ( -- )
    connection .data-rmap 0= ?EXIT
    net2o-code expect-msg
    log !time end-with join, get-ip end-code ;

: chat-entry ( -- )  ?.net2o/chats  word-args
    <warn> ." Type ctrl-D or '/bye' as single item to quit" <default> cr ;

also net2o-base
\ chain messages to one previous message
: chain, ( msgaddr u -- )
    [: 2dup startdate@ 64#0 { 64^ sd } sd le-64!  sd 1 64s forth:type
	c:0key sigonly@ >hash hashtmp hash#128 forth:type ;] $tmp $, msg-chain ;

: (send-avalanche) ( xt -- addr u flag )
    [: 0 >o [: <msg msg-start execute msg> ;] gen-cmd$ o>
      +last-signed msg-log, ;] [group] ;
previous
: send-avalanche ( xt -- )
    msg-group-o .msg:?otr IF  now>otr  ELSE  now>never  THEN
    (send-avalanche)
    >r .chat r> 0= IF  msg-group-o .msg:.nobody  THEN ;

\ chat helper words

Variable chat-keys

: @/ ( addr u -- addr1 u1 addr2 u2 ) '@' $split ;
: @/2 ( addr u -- addr2 u2 ) '@' $split 2nip ;

: @nick>chat ( addr u -- )
    host.nick>pk dup 0= !!no-nick!! chat-keys $+[]! ;

: @nicks>chat ( -- )
    ['] @nick>chat @arg-loop ;

: nick>chat ( addr u -- )
    @/ dup IF
	host.nick>pk dup 0= !!no-nick!!
	[: 2swap type ." @" type ;] $tmp
    ELSE  2drop  THEN
    chat-keys $+[]! ;

: nicks>chat ( -- )
    ['] 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 dup >r
	IF  msg-dec-sig?  ELSE  pk-sig?  THEN  !!sig!!
	2dup + sigpksize# - sigpksize#
	over keysize pk@ key| str= IF
	    keysize /string $,
	    r> new-otrsig $,
	    msg-otrify
	ELSE
	    rdrop 2drop 2drop ." not your message!" forth:cr
	THEN
    ELSE  drop  THEN ;

previous

\ debugging aids for classes

: .ack ( o:ack -- o:ack )
    ." ack context:" cr
    ." rtdelay: " rtdelay 64@ s64. cr ;

: .context ( o:context -- o:context )
    ." Connected with: " .con-id cr
    ack-context @ ?dup-IF  ..ack  THEN ;

: .notify ( -- )
    ." notify " config:notify?# ?
    ." led " config:notify-rgb# @ hex. config:notify-on# ? config:notify-off# ?
    ." interval " config:delta-notify& 2@ 1000000 um/mod . drop
    ." mode " config:notify-mode# @ .
    config:notify-text# @
    case
	-1 of  ." visible"  endof
	0 of  ." hidden"  endof
	1 of  ." hide-otr"  endof
    endcase
    forth:cr ;

: get-hex ( -- n )
    parse-name '$' skip #0. 2swap ['] >number $10 base-execute 2swap drop ;
: get-dec ( -- n )
    parse-name '#' skip #0. 2swap ['] >number #10 base-execute 2swap drop ;

scope: notify-cmds

: on ( -- ) -2 config:notify?# ! ;
: always ( -- ) -3 config:notify?# ! ;
: off ( -- ) 0 config:notify?# ! ;
: led ( -- ) \ "<rrggbb> <on-ms> <off-ms>"
    get-hex config:notify-rgb# !
    get-dec #500 max config:notify-on# !
    get-dec #500 max config:notify-off# !
    msg-builder ;
: interval ( -- ) parse-name
    #0. 2swap ['] >number #10 base-execute 1 = IF  nip c@ case
	    's' of     #1000 * endof
	    'm' of    #60000 * endof
	    'h' of #36000000 * endof
	endcase
    ELSE  2drop  THEN  #1000000 um* config:delta-notify& 2! ;
: mode ( -- )
    get-dec 3 and config:notify-mode# ! msg-builder ;
: visible ( -- )
    config:notify-text# forth:on ;
: hidden ( -- )
    config:notify-text# forth:off ;
: hide-otr ( -- )
    1 config:notify-text# ! ;

}scope

: .chathelp ( addr u -- addr u )
    ." /" source 7 /string type cr ;

: .n2o-version ( -- )
    ." n2o-" net2o-version forth:type ;
: .gforth-version ( -- )
    ." gforth-"
    case threading-method
	0 of debugging-method 0= IF ." fast-"  THEN  endof
	1 of ." itc-" endof
	2 of ." ditc-" endof
    endcase
    version-string forth:type '-' forth:emit
    machine forth:type ;

forward avalanche-text

false value away?

: group#map ( xt -- )
    msg-group# swap [{: xt: xt :}l cell+ $@ drop cell+ .xt ;] #map ;

uval-o chat-cmd-o

object uclass chat-cmd-o
also net2o-base scope: /chat
umethod /me ( addr u -- )
    \U me <action>          send string as action
    \G me: send remaining string as action
umethod /away ( addr u -- )
    \U away [<action>]      send string or "away from keyboard" as action
    \G away: send string or "away from keyboard" as action
synonym /back /away
umethod /otr ( addr u -- )
    \U otr on|off|message   turn otr mode on/off (or one-shot)
umethod /peers ( addr u -- )
    \U peers                list peers
    \G peers: list peers in all groups
umethod /gps ( addr u -- )
    \U gps                  send coordinates
    \G gps: send your coordinates
synonym /here /gps
umethod /chats ( addr u -- )
    \U chats                list chats
    \G chats: list all chats
umethod /nat ( addr u -- )
    \U nat                  list NAT info
    \G nat: list nat traversal information of all peers in all groups
umethod /renat ( addr u -- )
    \U renat                redo NAT traversal
    \G renat: redo nat traversal
umethod /help ( addr u -- )
    \U help                 show help
    \G help: list help
umethod /myaddrs ( addr u -- )
    \U myaddrs              list my addresses
    \G myaddrs: list my own local addresses (debugging)
umethod /!myaddrs ( addr u -- )
    \U !myaddrs             re-obtain my addresses
    \G !myaddrs: if automatic detection of address changes fail,
    \G !myaddrs: you can use this command to re-obtain your local addresses
umethod /notify ( addr u -- )
    \U notify always|on|off|led <rgb> <on-ms> <off-ms>|interval <time>[smh]|mode 0-3
    \G notify: Change notificaton settings
umethod /beacons ( addr u -- )
    \U beacons              list beacons
    \G beacons: list all beacons
umethod /n2o ( addr u -- )
    \U n2o <cmd>            execute n2o command
    \G n2o: Execute normal n2o command
umethod /invitations ( addr u -- )
    \U invitations          handle invitations
    \G invitations: handle invitations: accept, ignore or block invitations
umethod /sync ( addr u -- )
    \U sync [+date] [-date] synchronize logs
    \G sync: synchronize chat logs, starting and/or ending at specific
    \G sync: time/date
umethod /version ( addr u -- )
    \U version              version string
    \G version: print version string
umethod /log ( addr u -- )
    \U log [#lines]         show log
    \G log: show the log, default is a screenful
umethod /logstyle ( addr u -- )
    \U logstyle [+-style]   set log style
    \G logstyle: set log styles, the following settings exist:
    \G logstyle: +date      a date per log line
    \G logstyle: +num       a message number per log line
umethod /otrify ( addr u -- )
    \U otrify #line[s]      otrify message
    \G otrify: turn an older message of yours into an OTR message
umethod /lock ( addr u -- )
    \U lock {@nick}         lock down
    \G lock: lock down communication to list of nicks
umethod /unlock ( addr u -- )
    \U unlock               stop lock down
    \G unlock: stop lock down
umethod /lock? ( addr u -- )
    \U lock?                check lock status
    \G lock?: report lock status
umethod /perms ( addr u -- )
    \U perms roles {@keys}  set and change permissions of users
    \G perms: set permissions
umethod /bye ( addr u -- )
    \U bye
    \G bye: leaves the current chat
umethod /chat ( addr u -- )
    \U chat [group][@user]  switch/connect chat
    \G chat: switch to chat with user or group
umethod /split ( addr u -- )
    \U split                split load
    \G split: reduce distribution load by reconnecting
end-class chat-cmds

chat-cmds new Constant text-chat-cmd-o

text-chat-cmd-o to chat-cmd-o

:noname ( addr u -- )
    [: $, msg-action ;] send-avalanche ; is /me

:noname ( addr u -- )
    dup 0= IF  2drop
	away? IF  "I'm back"  ELSE  "Away from keyboard"  THEN
	away? 0= to away?
    THEN
    [: $, msg-action ;] send-avalanche ; is /away

:noname ( addr u -- )
    2dup s" on" str= >r
    2dup s" off" str= r@ or IF   2drop
	msg-group-o r@ IF  .msg:+otr  ELSE  .msg:-otr  THEN
	<info> ." === " r> IF  ." enter"  ELSE  ." leave"  THEN
	."  otr mode ===" <default> forth:cr
    ELSE  rdrop
	msg-group-o .msg:mode @ >r
	msg-group-o .msg:+otr avalanche-text
	r> msg-group-o .msg:mode !
    THEN ; is /otr

:noname ( addr u -- )  2drop
    [: msg:name$ .group ." : "
	msg:peers[] $@ bounds ?DO
	    space I @ >o .con-id space
	    ack@ .rtdelay 64@ 64>f 1n f* (.time) o>
	cell +LOOP  forth:cr ;] group#map ; is /peers

:noname ( addr u -- )  2drop
    coord! coord@ 2dup 0 -skip nip 0= IF  2drop
    ELSE
	[: $, msg-coord ;] send-avalanche
    THEN ; is /gps

:noname ( addr u -- )
    bl skip '/' skip
    2dup [: ."     \U " forth:type ;] $tmp ['] .chathelp search-help
    [: ."     \G " forth:type ':' forth:emit ;] $tmp ['] .cmd search-help ;
is /help

:noname ( addr u -- )
    2drop .invitations ; is /invitations

:noname ( addr u -- )
    2drop ." ===== chats: "
    [:  msg:name$ msg-group$ $@ str= IF ." *" THEN
	msg:name$ .group
	." [" msg:peers[] $[]# 0 .r ." ]#"
	msg:log[] $[]# u. ;] group#map
    ." =====" forth:cr ; is /chats

:noname ( addr u -- )  2drop
    [:  ." ===== Group: " msg:name$ .group ."  =====" forth:cr
	msg:peers[] $@ bounds ?DO
	    ." --- " I @ >o .con-id ." : " return-address .addr-path
	    ."  ---" forth:cr .nat-addrs o>
	cell +LOOP ;] group#map ; is /nat

:noname ( addr u -- )
    2drop
    ." ===== all =====" forth:cr    .my-addr$s
    ." ===== public =====" forth:cr .pub-addr$s
    ." ===== private =====" forth:cr .priv-addr$s ; is /myaddrs
:noname ( addr u -- )
    2drop !my-addr ; is /!myaddrs

:noname ( addr u -- )
    ['] notify-cmds evaluate-in .notify ; is /notify

:noname ( addr u -- )
    2drop ." === beacons ===" forth:cr
    beacons# [: dup $@ .address space
      cell+ $@ over 64@ .ticks space
      1 64s safe/string bounds ?DO
	  I 2@ ?dup-IF ..con-id space THEN .name
      2 cells +LOOP forth:cr ;] #map ; is /beacons

:noname ( addr u -- )
    s>unumber? IF  drop  ELSE  2drop 0  THEN  cells >r
    msg-group-o .msg:peers[] $@ r@ u<= IF  drop rdrop  EXIT  THEN
    r> + @ >o o to connection
    ." === sync ===" forth:cr
    net2o-code expect-msg [: msg-group last?, ;] [msg,] end-code o> ; is /sync

:noname ( addr u -- )
    2drop .n2o-version space .gforth-version forth:cr ; is /version

:noname ( addr u -- )
    s>unumber? IF  drop >r  ELSE  2drop rows >r  THEN
    msg-group$ $@ >group purge-log
    r>  display-lastn ; is /log

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

:noname ( addr u -- )
    [: BEGIN  bl $split 2>r dup  WHILE  s>number? WHILE
		    drop do-otrify  2r>  REPEAT THEN
	2drop 2r> 2drop  now>otr
    ;] (send-avalanche) drop .chat save-msgs& ; is /otrify

:noname ( addr u -- )
    msg-group-o .msg:-lock
    word-args ['] args>keylist execute-parsing
    [: key-list v-enc$ $, net2o-base:msg-lock ;] send-avalanche
    vkey keysize $make msg-group-o .msg:keys[] >back
    msg-group-o .msg:+lock
; is /lock
:noname ( addr u -- )
    2drop msg-group-o .msg:-lock
    [: net2o-base:msg-unlock ;] send-avalanche
; is /unlock
:noname ( addr u -- )
    2drop msg-group-o .msg:?lock 0= IF  ." un"  THEN  ." locked" forth:cr
; is /lock?

$100 buffer: permchar>bits
msg:role-admin# msg:key-admin# msg:moderator# or or 'a' permchar>bits + c!
msg:role-admin# 'r' permchar>bits + c!
msg:key-admin#  'k' permchar>bits + c!
msg:moderator#  'm' permchar>bits + c!
msg:troll#      't' permchar>bits + c!
: >perms ( addr u -- perms )
    0 -rot bounds ?DO  I c@ permchar>bits + c@
	dup 0= !!inv-perm!! or  LOOP ;

:noname ( addr u -- )
    word-args [: parse-name >perms args>keylist ;] execute-parsing
    [{: perm :}l
	perm key-list [: key| $, dup ulit, net2o-base:msg-perms ;] $[]map drop
    ;] send-avalanche
; is /perms

:noname ( addr u -- )
    2drop -1 [IFDEF] android android:level# [ELSE] level# [THEN] +! ; is /bye
}scope

: ?slash ( addr u -- addr u flag )
    over c@ dup '/' = swap '\' = or ;

: do-chat-cmd? ( addr u -- t / addr u f )
    ?slash dup 0= ?EXIT  drop
    over '/' swap c! bl $split 2swap
    2dup ['] /chat >body find-name-in
    ?dup-IF  nip nip name>int execute true
    ELSE  drop 1- -rot + over - false
    THEN ;

0 Value last->in

: ?flush-text ( addr -- )
    last->in ?dup-0=-IF  source drop  THEN
    tuck - dup IF
	\ ." text: '" forth:type ''' forth:emit forth:cr
	$, msg-text
    ELSE  2drop  THEN ;

: text-rec ( addr u -- )
    2drop ['] noop rectype-name ;
: tag-rec ( addr u -- )
    over c@ '#' = IF
	over ?flush-text 2dup + to last->in
	[: 1 /string
	    \ ." tag: '" forth:type ''' forth:emit forth:cr
	    $, msg-tag
	;] rectype-name
    ELSE  2drop rectype-null  THEN ;
: pk-rec ( addr u -- )
    over c@ '@' = IF  2dup 1 /string ':' -skip nick>pk
	2dup d0= IF  2drop 2drop rectype-null
	ELSE
	    2>r over ?flush-text + to last->in  2r>
	    [:
		\ ." signal: '" 85type ''' forth:emit forth:cr
		$, msg-signal
	    ;] rectype-name
	THEN
    ELSE  2drop rectype-null  THEN ;
: chain-rec ( addr u -- )
    over c@ '!' = IF
	2dup 1 /string dup 0= IF  2drop 2drop rectype-null  EXIT  THEN
	snumber?
	case
	    0 of  endof
	    -1 of
		msg-group-o .msg:log[] $[]#
		over abs over u< IF  over 0< IF  +  ELSE  drop  THEN
		    >r over ?flush-text + to last->in  r>
		    [: msg-group-o .msg:log[] $[]@ chain, ;]
		    rectype-name  EXIT  THEN
	    endof
	    2drop
	endcase
    THEN  2drop  rectype-null  ;
: http-rec ( addr u -- )
    2dup "https://" string-prefix? >r
    2dup "http://" string-prefix? r> or IF
	over ?flush-text 2dup + to last->in
	[: $, msg-url ;] rectype-name
    ELSE  2drop rectype-null  THEN ;

$Variable msg-recognizer
' text-rec ' http-rec ' chain-rec ' tag-rec ' pk-rec 5 msg-recognizer set-stack

: parse-text ( addr u -- ) last# >r  forth-recognizer >r
    0 to last->in
    msg-recognizer to forth-recognizer 2dup evaluate
    last->in IF  + last->in tuck -  THEN  dup IF
	\ ." text: '" forth:type ''' forth:emit forth:cr
	$, msg-text
    ELSE  2drop  THEN
    r> to forth-recognizer  r> to last# ;

: avalanche-text ( addr u -- )
    >utf8$ ['] parse-text send-avalanche ;

previous

: load-msgn ( addr u n -- )
    >r load-msg r> display-lastn ;

: +group ( -- ) msg-group$ $@ >group +unique-con ;

: msg-timeout ( -- )
    packets2 @  connected-timeout  packets2 @ <>
    IF  reply( ." Resend to " pubkey $@ key>nick type cr )
	timeout-expired? IF
	    timeout( <err> ." Excessive timeouts from "
	    pubkey $@ key>nick type ." : "
	    ack@ .timeouts @ . <default> cr )
	    msg-group$ $@len IF
		msg-group-o .msg:mode dup @ msg:otr# or swap
		[: pubkey $@ ['] left, send-avalanche ;] !wrapper
	    THEN
	    net2o:dispose-context
	    EXIT
	THEN
    ELSE  expected@ u<= IF  -timeout  THEN  THEN ;

: +resend-msg ( -- )
    ['] msg-timeout is timeout-xt  o+timeout ;

$B $E 2Value chat-bufs#

: +chat-control ( -- )
    +resend-msg +flow-control ;

: chat#-connect? ( addr u buf1 buf2 --- flag )
    pk-connect? dup IF  connection >o rdrop +chat-control  +group  THEN ;

: chat-connect ( addr u -- )
    chat-bufs# chat#-connect? IF  greet  THEN ;

: key-ctrlbit ( -- n )
    \G return a bit mask for the control key pressed
    1 key dup bl < >r lshift r> and ;

: wait-key ( -- )
    BEGIN  key-ctrlbit [ 1 ctrl L lshift 1 ctrl Z lshift or ]L
    and 0=  UNTIL ;

: chats# ( -- n )
    0 [: msg:peers[] $[]# 1 max + ;] group#map ;

: wait-chat ( -- )
    chat-keys [: @/2 dup 0= IF  2drop  EXIT  THEN
      2dup keysize2 safe/string tuck <info> type IF '.' emit  THEN
      .key-id space ;] $[]map
    ." is not online. press key to recheck."
    [: 0 to connection -56 throw ;] is do-disconnect
    [: false chat-keys [: @/2 key| pubkey $@ key| str= or ;] $[]map
	IF  bl inskey  THEN  up@ wait-task ! ;] is do-connect
    wait-key cr [: up@ wait-task ! ;] IS do-connect ;

: search-connect ( key u -- o/0 )  key|
    0 [: drop 2dup pubkey $@ key| str= o and  dup 0= ;] search-context
    nip nip  dup to connection ;

: search-peer ( -- chat )
    false chat-keys
    [: @/2 key| rot dup 0= IF drop search-connect
      ELSE  nip nip  THEN ;] $[]map ;

: key>group ( addr u -- pk u )
    @/ 2swap tuck msg-group$ $!  0=
    IF  2dup key| msg-group$ $!  THEN ; \ 1:1 chat-group=key

: ?load-msgn ( -- )
    msg-group$ $@ >group msg-group-o .msg:log[] $@len 0= IF
	msg-group$ $@ rows load-msgn  THEN ;

: chat-connects ( -- )
    chat-keys [: key>group ?load-msgn
      dup 0= IF  2drop msg-group$ $@ >group  EXIT  THEN
      2dup search-connect ?dup-IF  >o +group greet o> 2drop EXIT  THEN
      2dup pk-peek?  IF  chat-connect  ELSE  2drop  THEN ;] $[]map ;

: ?wait-chat ( -- addr u ) #0. /chat:/chats
    BEGIN  chats# 0= WHILE  wait-chat chat-connects  REPEAT
    msg-group$ $@ ; \ stub

scope{ /chat
:noname ( addr u -- )
    chat-keys $[]off nick>chat 0 chat-keys $[]@ key>group
    msg-group$ $@ >group msg-group-o .msg:peers[] $@ dup 0= IF  2drop
	nip IF  chat-connects
	ELSE  ." That chat isn't active" forth:cr  THEN
    ELSE
	bounds ?DO  2dup I @ .pubkey $@ key2| str= 0= WHILE  cell +LOOP
	    2drop chat-connects  ELSE  UNLOOP 2drop THEN
    THEN  #0. /chats ; is /chat
}scope

also net2o-base
: punch-addr-ind@ ( -- o )
    punch-addrs $[]# 0 U+DO
	I punch-addrs $[] @ .host:route $@len IF
	    I punch-addrs $[] @ unloop  EXIT
	THEN
    LOOP  0 punch-addrs $[] @ ;
: reconnect, ( o:connection -- )
    [: punch-addr-ind@ o>addr forth:type
      pubkey $@ key| tuck forth:type forth:emit ;] $tmp
    reconnect( ." send reconnect: " 2dup 2dup + 1- c@ 1+ - .addr$ forth:cr )
    $, msg-reconnect ;

: reconnects, ( o:group -- )
    msg-group-o .msg:peers[] $@ cell safe/string bounds U+DO
	I @ .reconnect,
    cell +LOOP ;

: send-reconnects ( o:group -- )
    net2o-code expect-msg
    [:  msg-group-o .msg:name$ ?destpk $, msg-leave
	<msg msg-start "left" $, msg-action msg-otr>
	reconnects, ;] [msg,]
    end-code| ;

: send-reconnect1 ( o:group -- )
    net2o-code expect-msg
    [:  msg:name$ ?destpk $, msg-leave
	<msg msg-start "left" $, msg-action msg-otr>
	.reconnect, ;] [msg,]
    end-code| ;
previous

: send-reconnect-xt ( o:group xt -- ) { xt: xt }
    msg:peers[] $@
    case
	0    of  drop  endof
	cell of  @ >o o to connection xt o>  endof
	drop @ >o o to connection  send-reconnects o>
	0
    endcase ;
: send-reconnect ( o:group -- )
    ['] send-leave send-reconnect-xt ;
: send-silent-reconnect ( o:group -- )
    ['] send-silent-leave send-reconnect-xt ;

: disconnect-group ( o:group -- )
    msg:peers[] get-stack 0 ?DO  >o o to connection
	disconnect-me o>
    LOOP ;
: disconnect-all ( o:group -- )
    msg:peers[] get-stack 0 ?DO  >o o to connection
	send-leave  disconnect-me o>
    LOOP ;

: leave-chat ( o:group -- )
    send-reconnect disconnect-group ;
: silent-leave-chat ( o:group -- )
    send-silent-reconnect disconnect-group ;

: leave-chats ( -- )
    ['] leave-chat group#map ;

: split-load ( o:group -- )
    msg:peers[] >r 0
    BEGIN  dup 1+ r@ $[]# u<  WHILE
	    dup r@ $[] 2@ .send-reconnect1
	    1+ dup r@ $[] @ >o o to connection disconnect-me o>
    REPEAT drop rdrop ;

scope{ /chat
:noname ( addr u -- )  2drop
    msg-group$ $@ >group msg-group-o .split-load ; is /split
}scope

\ chat toplevel

: do-chat ( addr u -- )
    get-order n>r
    chat-history  ['] /chat >body 1 set-order
    msg-group$ $! chat-entry \ ['] cmd( >body on
    [: up@ wait-task ! ;] IS do-connect
    BEGIN  get-input-line
	2dup "/bye" str= >r 2dup "\\bye" str= r> or 0= WHILE
	    do-chat-cmd? 0= IF  avalanche-text  THEN
    REPEAT  2drop leave-chats  xchar-history
    nr> set-order ;

: avalanche-to ( addr u o:context -- )
    avalanche( ." Send avalanche to: " pubkey $@ key>nick type space over hex. cr )
    o to connection
    net2o-code expect-msg message
    msg-group-o .msg:name$ 2dup pubkey $@ key| str= IF  2drop  ELSE  group,  THEN
    $, nestsig end-with
    end-code ;

\\\
Local Variables:
forth-local-words:
    (
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     ("[a-z\-0-9]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
    )
forth-local-indent-words:
    (
     (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate)
    )
End:
[THEN]