\ 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]