msg.fs 54.8 KB
Newer Older
bernd's avatar
bernd committed
1 2
\ messages                                           06aug2014py

bernd's avatar
bernd committed
3
\ Copyright (C) 2014-2016   Bernd Paysan
bernd's avatar
bernd committed
4 5 6 7 8 9 10 11 12 13 14 15 16 17

\ 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/>.

bernd's avatar
bernd committed
18 19
Forward avalanche-to ( addr u o:context -- )
Forward pk-connect ( key u cmdlen datalen -- )
20
Forward pk-connect? ( key u cmdlen datalen -- flag )
bernd's avatar
bernd committed
21 22
Forward addr-connect ( key+addr u cmdlen datalen xt -- )
Forward pk-peek? ( addr u0 -- flag )
bernd's avatar
bernd committed
23

bernd's avatar
bernd committed
24 25 26
: ?hash ( addr u hash -- ) >r
    2dup r@ #@ d0= IF  "" 2swap r> #!  ELSE  2drop rdrop  THEN ;

27 28
Variable otr-mode \ global otr mode

29 30
: >group ( addr u -- )
    2dup msg-group# #@ d0= IF
31 32 33
	net2o:new-msg >o 2dup to msg:name$
	otr-mode @ IF  msg:+otr  THEN
	o o>
34
	cell- [ msg-class >osize @ cell+ ]L
35 36
	2over msg-group# #!
    THEN  last# cell+ $@ drop cell+ to msg-group-o
37 38
    2drop ;

39
: avalanche-msg ( msg u1 o:connect -- )
bernd's avatar
bernd committed
40
    \G forward message to all next nodes of that message group
41 42 43
    { d: msgx }
    msg-group-o .msg:peers[] $@
    bounds ?DO  I @ o <> IF  msgx I @ .avalanche-to  THEN
44 45
    cell +LOOP ;

bernd's avatar
bernd committed
46
Variable msg-group$
bernd's avatar
bernd committed
47
User replay-mode
48
User skip-sig?
49

50
Sema msglog-sema
bernd's avatar
bernd committed
51

52
: ?msg-context ( -- o )
53 54
    msging-context @ dup 0= IF
	drop
55
	net2o:new-msging dup msging-context !
56
    THEN ;
bernd's avatar
bernd committed
57

58
: >chatid ( group u -- id u )  defaultkey sec@ keyed-hash#128 ;
bernd's avatar
bernd committed
59

60 61
: msg-log@ ( -- addr u )
    [: msg-group-o .msg:log[] $@ save-mem ;] msglog-sema c-section ;
bernd's avatar
bernd committed
62

63
: purge-log ( -- )
64
    [: msg-group-o .msg:log[] { a[] }
65 66 67 68 69 70 71 72 73
	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 ;

bernd's avatar
bernd committed
74
: serialize-log ( addr u -- $addr )
bernd's avatar
bernd committed
75
    [: bounds ?DO
76
	    I $@ check-date 0= IF  net2o-base:$, net2o-base:nestsig
Bernd Paysan's avatar
Bernd Paysan committed
77
	    ELSE   msg( ." removed entry " dump )else( 2drop )  THEN
bernd's avatar
bernd committed
78
      cell +LOOP ;]
bernd's avatar
bernd committed
79
    gen-cmd ;
bernd's avatar
bernd committed
80

81 82 83
Variable saved-msg$
64Variable saved-msg-ticks

84
: save-msgs ( group-o -- ) to msg-group-o
85
    msg( ." Save messages in group " msg-group-o dup hex. .msg:name$ type cr )
86
    ?.net2o/chats  net2o:new-msging >o
87
    msg-log@ over >r  serialize-log enc-file $!buf
bernd's avatar
bernd committed
88
    r> free throw  dispose o>
89
    msg-group-o .msg:name$ >chatid .chats/ enc-filename $!
bernd's avatar
bernd committed
90 91
    pk-off  key-list encfile-rest ;

92 93 94 95 96 97 98 99 100 101 102 103
: 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 ;

bernd's avatar
bernd committed
104
: msg-eval ( addr u -- )
105
    net2o:new-msging >o 0 to parent do-cmd-loop dispose o> ;
bernd's avatar
bernd committed
106

107
: load-msg ( group u -- )  2dup >group
Bernd Paysan's avatar
Bernd Paysan committed
108
    >chatid .chats/ [: type ." .v2o" ;] $tmp
109
    2dup file-status nip no-file# = IF  2drop EXIT  THEN
110
    replay-mode on  skip-sig? on
Bernd Paysan's avatar
Bernd Paysan committed
111
    ['] decrypt@ catch
bernd's avatar
bernd committed
112
    ?dup-IF  DoError 2drop
113
	\ try read backup instead
Bernd Paysan's avatar
Bernd Paysan committed
114 115 116 117 118
	[: 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 ;
119

120
event: :>save-msgs ( group-o -- ) saved-msg$ +unique$ ;
121 122
event: :>save-all-msgs ( -- )
    save-all-msgs ;
123 124
event: :>load-msg ( group-o -- )
    .msg:name$ load-msg ;
125 126

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

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

bernd's avatar
bernd committed
136
: save-msgs& ( -- )
137
    syncfile( msg-group-o saved-msg$ +unique$ )else(
138
    <event msg-group-o elit, :>save-msgs ?file-task event> ) ;
bernd's avatar
bernd committed
139

Bernd Paysan's avatar
Bernd Paysan committed
140
0 Value log#
141
2Variable last-msg
Bernd Paysan's avatar
Bernd Paysan committed
142

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

152
Sema queue-sema
153

154
\ peer queue, in msg context
155

156
: peer> ( -- addr / 0 )
157
    [: msg:peers[] back> ;] queue-sema c-section ;
bernd's avatar
bernd committed
158
: >peer ( addr u -- )
159
    [: msg:peers[] $+[]! ;] queue-sema c-section ;
160

161 162
\ events

163 164 165 166
msg-class class end-class msg-notify-class

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

167
: >msg-log ( addr u -- addr' u )
168
    +msg-log ?save-msg ;
bernd's avatar
bernd committed
169

170
: do-msg-nestsig ( addr u -- )
171
    2dup msg-group-o .msg:display
172
    msg-notify-o .msg:display ;
bernd's avatar
bernd committed
173

174
: display-lastn ( n -- )
175
    msg-group-o .msg:redisplay ;
Bernd Paysan's avatar
Bernd Paysan committed
176
: display-sync-done ( -- )
177
    rows  msg-group-o .msg:redisplay ;
bernd's avatar
bernd committed
178

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

bernd's avatar
bernd committed
184
Forward silent-join
185

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

188
: +unique-con ( -- ) o msg-group-o .msg:peers[] +unique$ ;
bernd's avatar
bernd committed
189
Forward +chat-control
190

191
: chat-silent-join ( -- )
bernd's avatar
bernd committed
192
    reconnect( ." silent join " o hex. connection hex. cr )
193 194
    o to connection
    ?msg-context >o silent-last# @ to last# o>
bernd's avatar
bernd committed
195
    reconnect( ." join: " last# $. cr )
bernd's avatar
bernd committed
196
    +unique-con silent-join ;
197 198

: chat-silent-rqd ( n -- )
bernd's avatar
bernd committed
199
    reconnect( ." silent requst" cr )
200 201
    clean-request chat-silent-join ;

bernd's avatar
bernd committed
202 203 204
: ?nat ( -- )  o to connection
    net2o-code nat-punch end-code ;

205
: ?chat-nat ( -- )
bernd's avatar
bernd committed
206
    ['] chat-silent-rqd rqd! ?nat ;
207

bernd's avatar
bernd committed
208 209
: chat-rqd-nat ( n -- )
    reconnect( ." chat req done, start nat traversal" cr )
210 211
    connect-rest  +flow-control +resend ?chat-nat ;

bernd's avatar
bernd committed
212 213 214 215
: chat-rqd-nonat ( n -- )
    reconnect( ." chat req done, start silent join" cr )
    connect-rest  +flow-control +resend chat-silent-join ;

216 217
User peer-buf

218
: reconnect-chat ( addr u $chat -- )
Bernd Paysan's avatar
Bernd Paysan committed
219 220 221 222 223 224
    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! ;]
225
    addr-connect 2dup d0= IF  2drop  ELSE  avalanche-to  THEN o> ;
226

227
event: :>avalanche ( addr u o group -- )
bernd's avatar
bernd committed
228
    avalanche( ." Avalanche to: " dup hex. cr )
229
    to msg-group-o .avalanche-msg ;
230
event: :>chat-reconnect ( addr u $chat o group -- )
231
    to msg-group-o .reconnect-chat ;
232
event: :>msg-nestsig ( $addr o group -- )
233
    to msg-group-o >o { w^ m } m $@ do-msg-nestsig m $free o>
234
    ctrl L inskey ;
235

bernd's avatar
bernd committed
236 237 238
\ coordinates

6 sfloats buffer: coord"
bernd's avatar
bernd committed
239
90e coord" sfloat+ sf!
bernd's avatar
bernd committed
240 241 242 243 244 245 246 247
: 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
bernd's avatar
bernd committed
248 249 250 251 252 253
	    getLatitude  coord" 0 sf[]!
	    getLongitude coord" 1 sf[]!
	    getAltitude  coord" 2 sf[]!
	    getSpeed     coord" 3 sf[]!
	    getBearing   coord" 4 sf[]!
	    getAccuracy  coord" 5 sf[]!
bernd's avatar
bernd committed
254 255 256 257
	    o>
	ELSE
	    start-gps
	THEN ;
bernd's avatar
bernd committed
258 259
    :noname level# @ 0> IF  -1 level# +!
	ELSE  ctrl U inskey ctrl D inskey THEN ; is aback
bernd's avatar
bernd committed
260 261
    previous
[ELSE]
bernd's avatar
bernd committed
262
    [IFDEF] has-gpsd?
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
	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]
bernd's avatar
bernd committed
281 282 283
    [ELSE]
	: coord! ( -- ) ;
    [THEN]
bernd's avatar
bernd committed
284 285
[THEN]

286
: .coords ( addr u -- ) $>align drop
bernd's avatar
bernd committed
287 288 289
    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 "
290
    dup 3 sf[]@ 8 2 0 f.rdp ." km/h "
bernd's avatar
bernd committed
291
    dup 4 sf[]@ 8 2 0 f.rdp ." ° ~"
bernd's avatar
bernd committed
292
    dup 5 sf[]@ fsplit 0 .r '.' emit 100e f* f>s .## ." m"
bernd's avatar
bernd committed
293 294
    drop ;

bernd's avatar
bernd committed
295
Forward msg:last?
bernd's avatar
bernd committed
296
Forward msg:last
297

298
: push-msg ( addr u o:parent -- )
299
    up@ receiver-task <> IF
300 301
	avalanche-msg
    ELSE wait-task @ ?dup-IF
302
	    <event >r e$, o elit, msg-group-o elit,
303
	    :>avalanche r> event>
304
	ELSE  2drop  THEN
305
    THEN ;
306
: show-msg ( addr u -- )
307
    parent dup IF  .wait-task @ dup up@ <> and  THEN
308
    ?dup-IF
309
	>r r@ <hide> <event $make elit, o elit, msg-group-o elit, :>msg-nestsig
310
	r> event>
bernd's avatar
bernd committed
311
    ELSE  do-msg-nestsig  THEN ;
bernd's avatar
bernd committed
312

bernd's avatar
bernd committed
313
: date>i ( date -- i )
314
    msg-group-o .msg:log[] $search[]date msg-group-o .msg:log[] $[]# 1- umin ;
315
: date>i' ( date -- i )
316
    msg-group-o .msg:log[] $search[]date msg-group-o .msg:log[] $[]# umin ;
317
: sighash? ( addr u -- flag )
bernd's avatar
bernd committed
318
    over le-64@ date>i
319 320
    dup 0< IF  drop 2drop  false  EXIT  THEN  >r
    over le-64@ 64#1 64+ date>i' >r [ 1 64s ]L /string
321
    r> r> U+DO
322
	c:0key I msg-group-o .msg:log[] $[]@ sigonly@ >hash
323
	2dup hashtmp over str= IF  2drop true  UNLOOP   EXIT
Bernd Paysan's avatar
Bernd Paysan committed
324
	ELSE  ( 2dup 85type ."  <> " hashtmp over 85type )  THEN
325 326 327
    LOOP
    2drop false ;

328
: msg-key! ( addr u -- )
Bernd Paysan's avatar
Bernd Paysan committed
329
    0 msg-group-o .msg:keys[] [: rot >r 2over str= r> or ;] $[]map
Bernd Paysan's avatar
Bernd Paysan committed
330
    IF  2drop  ELSE  \ ." msg-key+ " 2dup 85type forth:cr
Bernd Paysan's avatar
Bernd Paysan committed
331
	$make msg-group-o .msg:keys[] >back  THEN ;
332

Bernd Paysan's avatar
Bernd Paysan committed
333 334
\ message commands

bernd's avatar
bernd committed
335
scope{ net2o-base
bernd's avatar
bernd committed
336

337 338 339
\g 
\g ### message commands ###
\g 
bernd's avatar
bernd committed
340 341 342

reply-table $@ inherit-table msg-table

343
$20 net2o: msg-start ( $:pksig -- ) \g start message
344
    1 !!>order? $> msg:start ;
bernd's avatar
bernd committed
345
+net2o: msg-tag ( $:tag -- ) \g tagging (can be anywhere)
346
    $> msg:tag ;
347
+net2o: msg-id ( $:id -- ) \g a hash id
348
    2 !!>=order? $> msg:id ;
349
+net2o: msg-chain ( $:dates,sighash -- ) \g chained to message[s]
Bernd Paysan's avatar
Bernd Paysan committed
350
    ( $10 !!>=order? ) $> msg:chain ;
351
+net2o: msg-signal ( $:pubkey -- ) \g signal message to one person
352
    $> msg:signal ;
bernd's avatar
bernd committed
353
+net2o: msg-re ( $:hash ) \g relate to some object
354
    4 !!>=order? $> msg:re ;
355
+net2o: msg-text ( $:msg -- ) \g specify message string
356
    8 !!>=order? $> msg:text ;
357
+net2o: msg-object ( $:object type -- ) \g specify an object, e.g. an image
358
    8 !!>=order? 64>n $> rot msg:object ;
359
+net2o: msg-action ( $:msg -- ) \g specify action string
360
    8 !!>=order? $> msg:action ;
Bernd Paysan's avatar
Bernd Paysan committed
361
+net2o: msg-payment ( $:contract -- ) \g payment transaction
362
    8 !!>=order? $> msg:payment ;
363 364
+net2o: msg-otrify ( $:date+sig $:newdate+sig -- ) \g turn a past message into OTR
    $> $> msg:otrify ;
Bernd Paysan's avatar
Bernd Paysan committed
365 366
+net2o: msg-coord ( $:gps -- ) \g GPS coordinates
    8 !!>=order? $> msg:coord ;
367
+net2o: msg-url ( $:url -- ) \g specify message URL
368
    $> msg:url ;
Bernd Paysan's avatar
Bernd Paysan committed
369 370
+net2o: msg-like ( xchar -- ) \g add a like
    64>n msg:like ;
371 372
+net2o: msg-lock ( $:key -- ) \g lock down communciation
    $> msg:lock ;
373
+net2o: msg-unlock ( -- ) \g unlock communication
374
    msg:unlock ;
375 376
+net2o: msg-perms ( $:pk perm -- ) \g permissions
    $> msg:perms ;
Bernd Paysan's avatar
Bernd Paysan committed
377 378 379 380
}scope

msg-table $save

381 382
' context-table is gen-table

bernd's avatar
bernd committed
383 384
\ Code for displaying messages

Bernd Paysan's avatar
Bernd Paysan committed
385 386
Defer .log-num
Defer .log-date
387
Defer .log-end
Bernd Paysan's avatar
Bernd Paysan committed
388

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

Bernd Paysan's avatar
Bernd Paysan committed
400 401 402 403 404
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 ;
405 406
: +end [: 64dup .ticks space .otr ;] is .log-end ;
: -end ['] .otr is .log-end ;
Bernd Paysan's avatar
Bernd Paysan committed
407

408
+date -num -end
Bernd Paysan's avatar
Bernd Paysan committed
409 410
}scope

411 412 413 414 415 416 417 418 419 420 421
: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
Bernd Paysan's avatar
Bernd Paysan committed
422
' drop  msg-notify-class is msg:like
423 424
' 2drop  msg-notify-class is msg:lock
' noop  msg-notify-class is msg:unlock
425
:noname 2drop 64drop ; msg-notify-class is msg:perms
Bernd Paysan's avatar
Bernd Paysan committed
426
' drop  msg-notify-class is msg:away
427 428 429
' 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
Bernd Paysan's avatar
Bernd Paysan committed
430
:noname ( xchar -- ) ['] xemit $tmp notify+ ; msg-notify-class is msg:like
431

432
:noname ( addr u -- )
433 434 435 436
    last# >r  2dup key| to msg:id$
    .log-num
    2dup startdate@ .log-date
    2dup enddate@ .log-end
437
    .key-id ." : " 
438
    r> to last# ; msg-class is msg:start
bernd's avatar
bernd committed
439
:noname ( addr u -- ) $utf8>
440
    <warn> '#' forth:emit .group <default> ; msg-class is msg:tag
441
:noname ( addr u -- ) last# >r
442
    key| 2dup 0 .pk@ key| str=
443
    IF   <err>  THEN ." @" .key-id? <default>
444
    r> to last# ; msg-class is msg:signal
445
:noname ( addr u -- )
446
    last# >r last# $@ >group
447 448
    2dup sighash? IF  <info>  ELSE  <err>  THEN
    ."  <" over le-64@ .ticks
449
    verbose( dup keysize - /string ." ," 85type )else( 2drop ) <default>
450
    r> to last# ; msg-class is msg:chain
bernd's avatar
bernd committed
451
:noname ( addr u -- )
452
    space <warn> ." [" 85type ." ]->" <default> ; msg-class is msg:re
453
:noname ( addr u -- )
454
    space <warn> ." [" 85type ." ]:" <default> ; msg-class is msg:id
455
:noname ( addr u -- ) $utf8> forth:type ; msg-class is msg:text
bernd's avatar
bernd committed
456
:noname ( addr u -- ) $utf8>
Bernd Paysan's avatar
Bernd Paysan committed
457 458 459
    <warn> forth:type <default> ; msg-class is msg:url
:noname ( xchar -- )
    <info> utf8emit <default> ; msg-class is msg:like
460 461
:noname ( addr u -- )
    0 .v-dec$ dup IF
462
	msg-key!  msg-group-o .msg:+lock
Bernd Paysan's avatar
Bernd Paysan committed
463 464 465
	<info> ." chat is locked" <default>
    ELSE  2drop
	<err> ." locked out of chat" <default>
Bernd Paysan's avatar
Bernd Paysan committed
466
    THEN ; msg-class is msg:lock
467
:noname ( -- )  msg-group-o .msg:-lock
468
    <info> ." chat is free for all" <default> ; msg-class is msg:unlock
Bernd Paysan's avatar
Bernd Paysan committed
469
' drop msg-class is msg:away
470 471 472 473
: .perms ( n -- )
    "👹" bounds U+DO
	dup 1 and IF  I xc@ xemit  THEN  2/
    I I' over - x-size  +LOOP  drop ;
474 475
:noname { 64^ perm d: pk -- }
    perm [ 1 64s ]L pk msg-group-o .msg:perms# #!
476
    pk .key-id ." : " perm 64@ 64>n .perms space
477
; msg-class is msg:perms
478
:noname ( addr u type -- )
479 480 481 482 483 484
    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
Bernd Paysan's avatar
Bernd Paysan committed
485 486 487 488 489 490
	drop
	2dup keysize /string
	2dup printable? IF  '[' emit  type '@' emit
	ELSE  ." #["  85type ." /@"  THEN
	key| .key-id
	0
491
    endcase ." ]" <default> ;
492
msg-class is msg:object
bernd's avatar
bernd committed
493
:noname ( addr u -- ) $utf8>
494
    <warn> forth:type <default> ; msg-class is msg:action
495
:noname ( addr u -- )
496
    <warn> ."  GPS: " .coords <default> ; msg-class is msg:coord
497 498 499 500 501 502 503 504 505 506 507 508

: 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

509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529
\ 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 ;

530 531
: replace-sig { addrsig usig addrmsg umsg -- }
    addrsig usig addrmsg umsg usig - [: type type ;] $tmp
532
    2dup msg-dec?-sig? !!sig!! 2drop addrmsg umsg smove ;
Bernd Paysan's avatar
Bernd Paysan committed
533 534
: new-otrsig ( addr u flag -- addrsig usig )
    >r 2dup startdate@ old>otr
535
    predate-key keccak# c:key@ c:key# smove
Bernd Paysan's avatar
Bernd Paysan committed
536 537 538
    [: sktmp pkmod sk@ drop >modkey .encsign-rest ;]
    ['] .sig r@ select $tmp
    2dup + 2 - r> swap orc!
Bernd Paysan's avatar
Bernd Paysan committed
539
    ( 2dup dump ) 1 64s /string ;
540 541 542

:noname { sig u' addr u -- }
    u' 64'+ u =  u sigsize# = and IF
543
	last# >r last# $@ >group
544
	addr u startdate@ 64dup date>i >r 64#1 64+ date>i' r>
Bernd Paysan's avatar
Bernd Paysan committed
545
	2dup = IF  ."  [otrified] "  addr u startdate@ .ticks  THEN
546
	U+DO
547
	    I msg-group-o .msg:log[] $[]@
548
	    2dup + 2 - c@ $80 and IF  msg-dec-sig? drop  THEN
549 550
	    2dup dup sigpksize# - /string key| msg:id$ str= IF
		dup u - /string addr u str= IF
Bernd Paysan's avatar
Bernd Paysan committed
551
		    ."  OTRify #" I u.
552
		    sig u' I msg-group-o .msg:log[] $[]@ replace-sig
553
		    save-msgs&
Bernd Paysan's avatar
Bernd Paysan committed
554 555
		ELSE
		    ."  [OTRified] #" I u.
556 557
		THEN
	    ELSE
Bernd Paysan's avatar
Bernd Paysan committed
558 559 560
		."  ID mismatch: "
		2dup dup sigpksize# - /string key| 85type space
		msg:id$ 85type forth:cr
561 562 563 564
		2drop
	    THEN
	LOOP
	r> to last#
565
    THEN ; msg-class is msg:otrify
Bernd Paysan's avatar
Bernd Paysan committed
566

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

570
\g 
Bernd Paysan's avatar
Bernd Paysan committed
571
\g ### group description commands ###
572
\g 
Bernd Paysan's avatar
Bernd Paysan committed
573

574
hash: group#
Bernd Paysan's avatar
Bernd Paysan committed
575 576 577

static-a to allocater
align here
578
groups-class new Constant group-o
Bernd Paysan's avatar
Bernd Paysan committed
579 580 581 582 583 584 585 586
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 )
587
    sample-group$ 2over group# #! last>o to groups:id$ ;
Bernd Paysan's avatar
Bernd Paysan committed
588 589 590 591 592 593 594

cmd-table $@ inherit-table group-table

scope{ net2o-base

$20 net2o: group-name ( $:name -- ) \g group symbolic name
    $> make-group ;
Bernd Paysan's avatar
Bernd Paysan committed
595
+net2o: group-id ( $:group -- ) \g group id, is a pubkey
Bernd Paysan's avatar
Bernd Paysan committed
596 597 598
    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[] $+[]! ;
Bernd Paysan's avatar
Bernd Paysan committed
599 600
+net2o: group-admin ( $:adminkey -- ) \g set admin key
    group-o o = !!no-group-name!! $> groups:admin sec! ;
Bernd Paysan's avatar
Bernd Paysan committed
601 602 603 604 605 606 607 608 609 610 611 612
+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 )
613
    pk@ pkc swap move  sk@ skc swap move \ normalize pkc
Bernd Paysan's avatar
Bernd Paysan committed
614
    pkc keysize 3 * \ hash of pkc+pk1+skc keyed with "group"
Bernd Paysan's avatar
Bernd Paysan committed
615
    "group" keyed-hash#128 .chats/ ;
Bernd Paysan's avatar
Bernd Paysan committed
616 617

: read-chatgroups ( -- )
618
    0 ..chats/group [: type ." .v2o" ;] $tmp
Bernd Paysan's avatar
Bernd Paysan committed
619 620 621 622 623 624 625 626 627 628 629 630
    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
Bernd Paysan's avatar
Bernd Paysan committed
631
    groups:admin sec@ dup IF  sec$, group-admin  ELSE  2drop  THEN
Bernd Paysan's avatar
Bernd Paysan committed
632 633 634 635 636
    groups:perms# 64dup 64-0<> IF  lit, group-perms  ELSE  64drop  THEN
    o> ;

previous

637 638 639 640 641 642 643 644
: 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 ;

Bernd Paysan's avatar
Bernd Paysan committed
645
: save-chatgroups ( -- )
646
    0 ..chats/group enc-filename $!
647
    [: group# ['] serialize-chatgroup #map ;] gen-cmd enc-file $!buf
Bernd Paysan's avatar
Bernd Paysan committed
648 649
    pk-off  key-list encfile-rest ;

650 651 652 653 654 655 656 657 658 659 660 661 662 663 664
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 ;

Bernd Paysan's avatar
Bernd Paysan committed
665
: .chatgroup ( last# -- )
666 667
    dup $. space dup $@ rot cell+ $@ drop cell+ >o
    groups:id$ 2tuck str=
668 669
    IF  ." =" 2drop
    ELSE  ''' emit <info> 85type <default> ''' emit THEN space
Bernd Paysan's avatar
Bernd Paysan committed
670
    groups:member[] [: '@' emit .simple-id space ;] $[]map
Bernd Paysan's avatar
Bernd Paysan committed
671
\    ." admin " groups:admin[] [: '@' emit .simple-id space ;] $[]map
Bernd Paysan's avatar
Bernd Paysan committed
672 673 674
    ." +" groups:perms# x64.
    o> cr ;
: .chatgroups ( -- )
675 676
    groups>sort[]
    group-list[] $@ bounds ?DO  I @ .chatgroup  cell +LOOP ;
Bernd Paysan's avatar
Bernd Paysan committed
677

Bernd Paysan's avatar
Bernd Paysan committed
678 679 680 681
: ?pkgroup ( addr u -- addr u )
    \ if no group has been selected, use the pubkey as group
    last# 0= IF  2dup + sigpksize# - keysize >group  THEN ;

Bernd Paysan's avatar
Bernd Paysan committed
682 683 684 685 686 687 688
: 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 ;
Bernd Paysan's avatar
Bernd Paysan committed
689

690 691 692 693
\g 
\g ### messaging commands ###
\g 

Bernd Paysan's avatar
Bernd Paysan committed
694 695
scope{ net2o-base

Bernd Paysan's avatar
Bernd Paysan committed
696
$34 net2o: message ( -- o:msg ) \g push a message object
697
    perm-mask @ perm%msg and 0= !!msg-perm!!
698
    ?msg-context n:>o c-state off  0 to last# ;
699

700 701 702 703
msging-table >table

reply-table $@ inherit-table msging-table

bernd's avatar
bernd committed
704
$21 net2o: msg-group ( $:group -- ) \g set group
705
    $> >group ;
706
+net2o: msg-join ( $:group -- ) \g join a chat group
707
    $> >load-group parent >o
bernd's avatar
bernd committed
708
    +unique-con +chat-control
709
    wait-task @ ?dup-IF  <hide>  THEN
bernd's avatar
bernd committed
710
    o> ;
711
+net2o: msg-leave ( $:group -- ) \g leave a chat group
712
    $> >group parent msg-group-o .msg:peers[] del$cell ;
713
+net2o: msg-reconnect ( $:pubkey+addr -- ) \g rewire distribution tree
Bernd Paysan's avatar
Bernd Paysan committed
714
    $> $make
715
    <event last-msg 2@ e$, elit, o elit, msg-group-o elit, :>chat-reconnect
Bernd Paysan's avatar
Bernd Paysan committed
716
    parent .wait-task @ ?query-task over select event> ;
bernd's avatar
bernd committed
717 718
+net2o: msg-last? ( start end n -- ) 64>n msg:last? ;
+net2o: msg-last ( $:[tick0,msgs,..tickn] n -- ) 64>n msg:last ;
bernd's avatar
bernd committed
719

720
net2o' nestsig net2o: msg-nestsig ( $:cmd+sig -- ) \g check sig+nest
Bernd Paysan's avatar
Bernd Paysan committed
721
    $> nest-sig ?dup-0=-IF
Bernd Paysan's avatar
Bernd Paysan committed
722
	handle-msg
Bernd Paysan's avatar
Bernd Paysan committed
723 724
    ELSE  replay-mode @ IF  drop  ELSE  !!sig!!  THEN
	2drop 2drop \ balk on all wrong signatures
Bernd Paysan's avatar
Bernd Paysan committed
725
    THEN ;
bernd's avatar
bernd committed
726

727 728
\ generate an encryt+sign packet

Bernd Paysan's avatar
Bernd Paysan committed
729
: ]encpksign ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
730 731 732
    +zero16 nest$
    0 msg-group-o .msg:keys[] $[]@ encrypt$
    ['] .encsign ']nestsig ;
733 734 735

\ nest-sig for msg/msging classes

736 737 738
' message msging-class is start-req
:noname check-date >r 2dup r> ; msging-class is nest-sig
' message msg-class is start-req
Bernd Paysan's avatar
Bernd Paysan committed
739
:noname 2dup msg-dec?-sig? ; msg-class is nest-sig
Bernd Paysan's avatar
Bernd Paysan committed
740

bernd's avatar
bernd committed
741 742
' context-table is gen-table

bernd's avatar
bernd committed
743
also }scope
bernd's avatar
bernd committed
744

Bernd Paysan's avatar
Bernd Paysan committed
745 746
msging-table $save

Bernd Paysan's avatar
Bernd Paysan committed
747
: msg-reply ( tag -- )
748
    ." got reply " hex. pubkey $@ key>nick forth:type forth:cr ;
Bernd Paysan's avatar
Bernd Paysan committed
749
: expect-msg ( o:connection -- )
750
    reply( ['] msg-reply )else( ['] drop ) expect-reply-xt +chat-control ;
Bernd Paysan's avatar
Bernd Paysan committed
751

bernd's avatar
bernd committed
752
User hashtmp$  hashtmp$ off
bernd's avatar
bernd committed
753

754 755
: last-msg@ ( -- ticks )
    last# >r
756 757
    last# $@ >group msg-group-o .msg:log[] $[]# ?dup-IF
	1- msg-group-o .msg:log[] $[]@ startdate@
758
    ELSE  64#0  THEN   r> to last# ;
bernd's avatar
bernd committed
759 760
: l.hashs ( end start -- hashaddr u )
    hashtmp$ $off
761 762
    msg-group-o .msg:log[] $[]# IF
	[: U+DO  I msg-group-o .msg:log[] $[]@ 1- dup 1 64s - safe/string forth:type
763 764 765 766
	  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 ;
bernd's avatar
bernd committed
767
: i.date ( i -- )
768
    msg-group-o .msg:log[] $[]@ startdate@ 64#0 { 64^ x }
bernd's avatar
bernd committed
769
    x le-64! x 1 64s forth:type ;
770
: i.date+1 ( i -- )
771
    msg-group-o .msg:log[] $[]@ startdate@ 64#0 { 64^ x }
772
    64#1 64+ x le-64! x 1 64s forth:type ;
773
: last-msgs@ ( startdate enddate n -- addr u n' )
bernd's avatar
bernd committed
774 775 776 777 778
    \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
779 780
    last# >r >r last# $@ >group purge-log
    msg-group-o .msg:log[] $[]#
bernd's avatar
bernd committed
781
    IF
782
	date>i' >r date>i' r> swap
bernd's avatar
bernd committed
783
	2dup - r> over >r 1- 1 max / 0 max 1+ -rot
bernd's avatar
bernd committed
784
	[: over >r U+DO  I i.date
785
	      dup I + I' umin I l.hashs forth:type
786
	  dup +LOOP
787
	  r> dup msg-group-o .msg:log[] $[]# u< IF  i.date
788
	  ELSE  1- i.date+1  THEN
789
	  drop ;] $tmp r> \ over 1 64s u> -
790
    ELSE  rdrop 64drop 64drop s" "  0 THEN   r> to last# ;
791

bernd's avatar
bernd committed
792 793 794 795 796 797 798 799 800
\ 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 -- )
bernd's avatar
bernd committed
801
    state-addr >o  msgfs-class# fs-class! w/o fs-create o> ;
802
: .chat-file ( addr u -- )
bernd's avatar
bernd committed
803
    over le-64@ .ticks 1 64s /string  ." ->"
804 805
    over le-64@ .ticks 1 64s /string  ." @"
    .group ;
806
in net2o : copy-msg ( filename u -- )
bernd's avatar
bernd committed
807
    ." copy msg: " 2dup .chat-file forth:cr
bernd's avatar
bernd committed
808
    [: msgfs-class# ulit, file-type 2dup $, r/o ulit, open-sized-file
bernd's avatar
bernd committed
809
      file-reg# @ save-to-msg ;] n2o>file
bernd's avatar
bernd committed
810
    1 file-count +! ;
bernd's avatar
bernd committed
811

bernd's avatar
bernd committed
812
$20 Value max-last#
bernd's avatar
bernd committed
813 814 815
$20 Value ask-last#

Variable ask-msg-files[]
bernd's avatar
bernd committed
816

bernd's avatar
bernd committed
817
: msg:last? ( start end n -- )
bernd's avatar
bernd committed
818
    last# $@ $, msg-group
bernd's avatar
bernd committed
819
    max-last# umin
820
    last-msgs@ >r $, r> ulit, msg-last ;
bernd's avatar
bernd committed
821
: ?ask-msg-files ( addr u -- )
bernd's avatar
bernd committed
822
    64#-1 64#0 { 64^ startd 64^ endd } \ byte order of 0 and -1 don't matter
823
    last# $@ >group
bernd's avatar
bernd committed
824 825
    $> bounds ?DO
	I' I 64'+ u> IF
826 827 828
	    I le-64@ date>i'
	    I 64'+ 64'+ le-64@ date>i' swap
	    l.hashs drop le-64@
829
	    I 64'+ le-64@ 64<> IF
830 831
		I 64@ startd le-64@ 64umin
		I 64'+ 64'+ 64@ endd le-64@ 64umax
832
	    ELSE
833 834 835 836 837 838
		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!
bernd's avatar
bernd committed
839
	THEN
bernd's avatar
bernd committed
840
    2 64s +LOOP
bernd's avatar
bernd committed
841 842 843
    startd le-64@ 64#-1 64<> IF
	endd startd [: 1 64s forth:type 1 64s forth:type last# $. ;]
	ask-msg-files[] dup $[]# swap $[] $exec
bernd's avatar
bernd committed
844 845 846 847
    THEN ;
: msg:last ( $:[tick0,tick1,...,tickn] n -- )
    last# >r  ask-msg-files[] $[]off
    forth:. ." Messages:" forth:cr
848
    ?ask-msg-files ask-msg-files[] $[]# IF
849
	parent >o  expect+slurp
bernd's avatar
bernd committed
850
	cmdbuf# @ 0= IF  $10 blocksize! $1 blockalign!  THEN
851
	ask-msg-files[] ['] net2o:copy-msg $[]map o>
852 853
    ELSE
	." === nothing to sync ===" forth:cr
Bernd Paysan's avatar
Bernd Paysan committed
854
	parent .sync-none-xt \ sync-nothing-xt???
855
    THEN
bernd's avatar
bernd committed
856
    r> to last# ;
bernd's avatar
bernd committed
857

bernd's avatar
bernd committed
858 859 860
:noname ( -- 64len )
    \ poll serializes the 
    fs-outbuf $off
861 862
    fs-path $@ 2 64s /string >group
    msg-log@ over >r
bernd's avatar
bernd committed
863
    fs-path $@ drop le-64@ date>i \ start index
864
    fs-path $@ drop 64'+ le-64@ 64#1 64+ date>i' \ end index
bernd's avatar
bernd committed
865
    over - >r
bernd's avatar
bernd committed
866
    cells safe/string r> cells umin
bernd's avatar
bernd committed
867
    req? @ >r req? off  serialize-log   r> req? !  fs-outbuf $!buf
bernd's avatar
bernd committed
868
    r> free throw
bernd's avatar
bernd committed
869 870
    fs-outbuf $@len u>64 ; msgfs-class is fs-poll
:noname ( addr u mode -- )
bernd's avatar
bernd committed
871
    \G addr u is starttick endtick name concatenated together
bernd's avatar
bernd committed
872
    fs-close drop fs-path $!  fs-poll fs-size!
bernd's avatar
bernd committed
873
    ['] noop is file-xt
bernd's avatar
bernd committed
874
; msgfs-class is fs-open
bernd's avatar
bernd committed
875 876

\ syncing done
877
: chat-sync-done ( group-addr u -- )
878
    msg( ." chat-sync-done " 2dup forth:type forth:cr )
879
    >group display-sync-done !save-all-msgs
Bernd Paysan's avatar
Bernd Paysan committed
880
    net2o-code expect-msg close-all net2o:gen-reset end-code
881
    net2o:close-all
882
    ." === sync done ===" forth:cr sync-done-xt ;
883
event: :>msg-eval ( parent $pack $addr -- )
884
    { w^ buf w^ group }
885
    group $@ 2 64s /string { d: gname }
886 887
    gname >group
    msg-group-o .msg:log[] $[]# u.
bernd's avatar
bernd committed
888
    buf $@ true replay-mode ['] msg-eval !wrapper
889
    buf $free ?save-msg
890
    group $@ .chat-file ."  saved "
891
    msg-group-o .msg:log[] $[]# u. forth:cr
892
    >o -1 file-count +!@ 1 =
893
    IF  gname chat-sync-done  THEN  group $free
894
    o> ;
bernd's avatar
bernd committed
895
: msg-file-done ( -- )
bernd's avatar
bernd committed
896
    fs-path $@len IF
897
	msg( ." msg file done: " fs-path $@ .chat-file forth:cr )
898
	['] fs-flush file-sema c-section
bernd's avatar
bernd committed
899
    THEN ;
bernd's avatar
bernd committed
900 901
:noname ( addr u mode -- )
    fs-close drop fs-path $!
bernd's avatar
bernd committed
902
    ['] msg-file-done is file-xt
bernd's avatar
bernd committed
903
; msgfs-class is fs-create
bernd's avatar
bernd committed
904 905 906
:noname ( addr u -- u )
    [ termserver-class :: fs-read ]
; msgfs-class is fs-read
bernd's avatar
bernd committed
907
:noname ( -- )
908
	<event parent elit, 0 fs-inbuf !@ elit,  0 fs-path !@ elit, :>msg-eval
909
	parent .wait-task @ event>
bernd's avatar
bernd committed
910
	fs:fs-clear
911 912 913 914 915 916
; 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
bernd's avatar
bernd committed
917
    THEN
bernd's avatar
bernd committed
918 919 920
; msgfs-class is fs-close
:noname ( perm -- )
    perm%msg and 0= !!msg-perm!!
921
; msgfs-class is fs-perm?
bernd's avatar
bernd committed
922 923 924 925 926
: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
bernd's avatar
bernd committed
927 928 929

\ message composer

930
: group, ( addr u -- )
bernd's avatar
bernd committed
931
    $, msg-group ;
Bernd Paysan's avatar
Bernd Paysan committed
932 933 934
: <msg ( -- )
    sign[ msg-group-o .msg:?lock IF  +zero16  THEN ;

bernd's avatar
bernd committed
935
: msg> ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
936
    \G end a message block by adding a signature
937
    msg-group-o .msg:?lock IF  ]encpksign  ELSE  ]pksign  THEN ;
938
: msg-otr> ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
939
    \G end a message block by adding a short-time signature
Bernd Paysan's avatar
Bernd Paysan committed
940
    now>otr msg> ;
bernd's avatar
bernd committed
941 942
: msg-log, ( -- addr u )
    last-signed 2@ >msg-log ;
bernd's avatar
bernd committed
943 944 945

previous

bernd's avatar
bernd committed
946
: ?destpk ( addr u -- addr' u' )
Bernd Paysan's avatar
Bernd Paysan committed
947
    2dup connection .pubkey $@ key| str= IF  2drop pk@ key|  THEN ;
bernd's avatar
bernd committed
948

bernd's avatar
bernd committed
949
: last-signdate@ ( -- 64date )
950
    msg-group-o .msg:log[] $@ dup IF
Bernd Paysan's avatar
Bernd Paysan committed
951
	+ cell- $@ startdate@ 64#1 64+
bernd's avatar
bernd committed
952 953
    ELSE  2drop 64#-1  THEN ;

954
also net2o-base
bernd's avatar
bernd committed
955
: [msg,] ( xt -- )  last# >r
Bernd Paysan's avatar
Bernd Paysan committed
956
    msg-group$ $@ dup IF  message ?destpk 2dup >group $,
bernd's avatar
bernd committed
957 958 959 960
	execute  end-with
    ELSE  2drop drop  THEN  r> to last# ;

: last, ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
961
    64#0 64#-1 ask-last# last-msgs@ >r $, r> ulit, msg-last ;
bernd's avatar
bernd committed
962 963

: last?, ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
964
    last-signdate@ { 64: date }
965
    64#0 lit, date lit, ask-last# ulit, msg-last?
bernd's avatar
bernd committed
966
    date 64#-1 64<> IF
967
	date lit, 64#-1 lit, 1 ulit, msg-last?
bernd's avatar
bernd committed
968
    THEN ;
969

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

bernd's avatar
bernd committed
973
: join, ( -- )
974
    [: msg-join sync-ahead?,
Bernd Paysan's avatar
Bernd Paysan committed
975
      <msg msg-start "joined" $, msg-action msg-otr> ;] [msg,] ;
bernd's avatar
bernd committed
976

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

bernd's avatar
bernd committed
981
: leave, ( -- )
982
    [: msg-leave
Bernd Paysan's avatar
Bernd Paysan committed
983
      <msg msg-start "left" $, msg-action msg-otr> ;] [msg,] ;
984

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

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

992
: send-join ( -- )
993
    net2o-code expect-msg join,
994
    ( cookie+request ) end-code| ;
bernd's avatar
bernd committed
995

bernd's avatar
bernd committed
996
: silent-join ( -- )
997
    net2o-code expect-msg silent-join,
bernd's avatar
bernd committed
998
    end-code ;
999

1000
: send-leave ( -- )
1001
    connection .data-rmap IF  net2o-code expect-msg leave, end-code|  THEN ;
1002
: send-silent-leave ( -- )
1003
    connection .data-rmap IF  net2o-code expect-msg silent-leave, end-code|  THEN ;
bernd's avatar
bernd committed
1004

1005
: [group] ( xt -- flag )
1006 1007
    msg-group-o .msg:peers[] $@len IF
	msg-group-o .execute true
bernd's avatar
bernd committed
1008 1009 1010
    ELSE
	0 .execute false
    THEN ;
1011
: .chat ( addr u -- )
1012
    [: last# >r o IF  2dup do-msg-nestsig
1013
      ELSE  2dup display-one-msg  THEN  r> to last#
1014
      0 .avalanche-msg ;] [group] drop notify- ;
bernd's avatar
bernd committed
1015

1016 1017
\ chat message, text only

Bernd Paysan's avatar
Bernd Paysan committed
1018
: msg-tdisplay ( addr u -- )
1019
    2dup 2 - + c@ $80 and IF  msg-dec-sig? IF
Bernd Paysan's avatar
Bernd Paysan committed
1020 1021
	    2drop <err> ." Undecryptable message" <default> cr  EXIT
	THEN  <info>  THEN
Bernd Paysan's avatar
Bernd Paysan committed
1022
    sigpksize# - 2dup + sigpksize# >$  c-state off
1023
    nest-cmd-loop msg:end <default> ;
1024
' msg-tdisplay msg-class is msg:display
1025
' msg-tdisplay msg-notify-class is msg:display
1026 1027 1028 1029 1030 1031
: ?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 ;
1032
: msg-tredisplay ( n -- )
1033
    reset-time
Bernd Paysan's avatar
Bernd Paysan committed
1034
    msg-group-o >o msg:?otr msg:-otr o> >r
1035 1036 1037
    [:  cells >r msg-log@
	{ log u } u r> - 0 max { u' }  log u' ?search-lock
	log u u' /string bounds ?DO