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

3
\ Copyright © 2014-2019   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 )
21
Forward pk-connect-dests?
bernd's avatar
bernd committed
22 23
Forward addr-connect ( key+addr u cmdlen datalen xt -- )
Forward pk-peek? ( addr u0 -- flag )
bernd's avatar
bernd committed
24

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

28 29
Variable otr-mode \ global otr mode

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

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

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

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

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

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

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

64
: purge-log ( -- )
65
    [: msg-group-o .msg:log[] { a[] }
66 67 68 69 70 71 72 73 74
	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
75
: serialize-log ( addr u -- $addr )
bernd's avatar
bernd committed
76
    [: bounds ?DO
77
	    I $@ check-date 0= IF  net2o-base:$, net2o-base:nestsig
Bernd Paysan's avatar
Bernd Paysan committed
78
	    ELSE   msg( ." removed entry " dump )else( 2drop )  THEN
bernd's avatar
bernd committed
79
      cell +LOOP ;]
bernd's avatar
bernd committed
80
    gen-cmd ;
bernd's avatar
bernd committed
81

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

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

93 94 95 96 97 98 99 100 101 102 103 104
: 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
105
: msg-eval ( addr u -- )
106
    net2o:new-msging >o 0 to parent do-cmd-loop dispose o> ;
bernd's avatar
bernd committed
107

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

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

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

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

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

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

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

153
Sema queue-sema
154

155
\ peer queue, in msg context
156

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

162 163
\ events

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

217 218
User peer-buf

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

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

bernd's avatar
bernd committed
237 238 239
\ coordinates

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

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

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

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

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

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

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

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

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

reply-table $@ inherit-table msg-table

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

msg-table $save

382 383
' context-table is gen-table

384
\ Code for displaying messages: logstyle for TUI deferred-based
bernd's avatar
bernd committed
385

386 387 388
Variable log-mask
1 4 bits: log#num log#date log#end log#perm

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 399 400 401 402 403 404 405 406 407 408 409

: .log-num  ( -- )
    log-mask @ log#num  and IF '#' emit log# u.  THEN ;
: .log-date ( 64ticks -- )
    log-mask @ log#date and IF .ticks space  ELSE  64drop  THEN ;
: .log-end  ( 64ticks -- )
    log-mask @ log#end  and IF  64dup .ticks space  THEN  .otr ;

\ logstyle for GUI bitmask-based

Defer update-log
' noop is update-log

410 411
: .group ( addr u -- )
    2dup printable? IF  forth:type  ELSE  ." @" .key-id  THEN ;
412

Bernd Paysan's avatar
Bernd Paysan committed
413
scope: logstyles
414 415 416 417 418 419
: +num  log#num  log-mask or! update-log ;
: -num  log#num  invert log-mask and! update-log ;
: +date log#date log-mask or! update-log ;
: -date log#date invert log-mask and! update-log ;
: +end  log#end  log-mask or! update-log ;
: -end  log#end  invert log-mask and! update-log ;
Bernd Paysan's avatar
Bernd Paysan committed
420

421
+date -num -end
Bernd Paysan's avatar
Bernd Paysan committed
422 423
}scope

424 425 426 427 428 429 430 431 432 433 434
: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
435
' drop  msg-notify-class is msg:like
436 437
' 2drop  msg-notify-class is msg:lock
' noop  msg-notify-class is msg:unlock
438
:noname 2drop 64drop ; msg-notify-class is msg:perms
Bernd Paysan's avatar
Bernd Paysan committed
439
' drop  msg-notify-class is msg:away
440 441 442
' 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
443
:noname ( xchar -- ) ['] xemit $tmp notify+ ; msg-notify-class is msg:like
444

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

492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
hash: fetch-queue#
hash: fetch-finish#
Variable queued#

event: :>del-queue { d: pk d: hashs -- }
    pk fetch-queue# #@ d0<> IF
	hashs last# cell+ $@ string-prefix? IF
	    last# cell+ 0 hashs nip $del
	    last# cell+ $@len 0= IF
		last# $free last# cell+ $free
	    THEN
	THEN
    THEN  hashs drop free throw
    -1 queued# +! ;
event: :>hash-finished { d: hash }
507
    hash fetch-finish# #@ IF
508 509 510 511 512
	@ >r hash r@ execute r> >addr free throw
	last# bucket-off
    ELSE  drop  THEN ;

: fetch-queue { task d: pk d: hashs -- }
513
    pk $8 $E pk-connect? IF  +resend +flow-control
514 515 516 517 518
	hashs bounds U+DO
	    net2o-code expect+slurp $10 blocksize! $A blockalign!
	    I' I keysize $10 * + umin I U+DO
		I keysize net2o:copy#
		I keysize up@ [{: d: hash task :}h
519
		    <event hash e$, :>hash-finished task event> ;]
520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552
		lastfile@ >o to file-xt o>
	    keysize +LOOP
	end-code| net2o:close-all
	keysize $10 *  +LOOP
	disconnect-me
    ELSE
	hashs drop 0 to hashs
    THEN
    <event pk e$, hashs e$, :>del-queue task event> ;

event: :>fetch-queue fetch-queue ;

: transmit-queue ( -- )
    fetch-queue#
    [:  1 queued# +! <event up@ elit, dup $@ e$, cell+ $@ save-mem e$,
	:>fetch-queue ?query-task event> ;] #map ;

Variable queue?
event: :>queued ( -- )
    transmit-queue  queue? off ;
: enqueue ( -- )
    queue? @ 0= IF  queue? on <event :>queued up@ event>  THEN ;

: ?#+! ( addr1 u1 addr2 u2 hash -- ) >r
    2dup r@ #@ d0= IF  r> #! enqueue  ELSE  2drop rdrop
	last# cell+ $@ bounds U+DO
	    2dup I over str= IF  2drop unloop  EXIT  THEN
	dup +LOOP  last# cell+ $+! enqueue
    THEN ;

forward need-hashed?
: ?fetch ( addr u -- )
    key| 2dup need-hashed? IF  msg:id$ fetch-queue# ?#+!  ELSE  2drop  THEN ;
553

554
:noname ( addr u type -- )
555
    space <warn> case
Bernd Paysan's avatar
Bernd Paysan committed
556 557 558 559
	msg:image#     of  ." img["      2dup 85type ?fetch  endof
	msg:thumbnail# of  ." thumb["    2dup key| 85type
	    space 2dup keysize safe/string IF  c@ '0' + emit  ELSE  drop  THEN
	    ?fetch  endof
560 561 562
	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
563 564 565 566 567 568
	drop
	2dup keysize /string
	2dup printable? IF  '[' emit  type '@' emit
	ELSE  ." #["  85type ." /@"  THEN
	key| .key-id
	0
569
    endcase ." ]" <default> ;
570
msg-class is msg:object
bernd's avatar
bernd committed
571
:noname ( addr u -- ) $utf8>
572
    <warn> forth:type <default> ; msg-class is msg:action
573
:noname ( addr u -- )
574
    <warn> ."  GPS: " .coords <default> ; msg-class is msg:coord
575 576 577 578 579 580 581 582 583 584 585 586

: 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

587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607
\ 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 ;

608 609
: replace-sig { addrsig usig addrmsg umsg -- }
    addrsig usig addrmsg umsg usig - [: type type ;] $tmp
610
    2dup msg-dec?-sig? !!sig!! 2drop addrmsg umsg smove ;
Bernd Paysan's avatar
Bernd Paysan committed
611 612
: new-otrsig ( addr u flag -- addrsig usig )
    >r 2dup startdate@ old>otr
613
    predate-key keccak# c:key@ c:key# smove
Bernd Paysan's avatar
Bernd Paysan committed
614 615 616
    [: sktmp pkmod sk@ drop >modkey .encsign-rest ;]
    ['] .sig r@ select $tmp
    2dup + 2 - r> swap orc!
Bernd Paysan's avatar
Bernd Paysan committed
617
    ( 2dup dump ) 1 64s /string ;
618 619 620

:noname { sig u' addr u -- }
    u' 64'+ u =  u sigsize# = and IF
621
	last# >r last# $@ >group
622
	addr u startdate@ 64dup date>i >r 64#1 64+ date>i' r>
Bernd Paysan's avatar
Bernd Paysan committed
623
	2dup = IF  ."  [otrified] "  addr u startdate@ .ticks  THEN
624
	U+DO
625
	    I msg-group-o .msg:log[] $[]@
626
	    2dup + 2 - c@ $80 and IF  msg-dec-sig? drop  THEN
627 628
	    2dup dup sigpksize# - /string key| msg:id$ str= IF
		dup u - /string addr u str= IF
Bernd Paysan's avatar
Bernd Paysan committed
629
		    ."  OTRify #" I u.
630
		    sig u' I msg-group-o .msg:log[] $[]@ replace-sig
631
		    save-msgs&
Bernd Paysan's avatar
Bernd Paysan committed
632 633
		ELSE
		    ."  [OTRified] #" I u.
634 635
		THEN
	    ELSE
Bernd Paysan's avatar
Bernd Paysan committed
636 637 638
		."  ID mismatch: "
		2dup dup sigpksize# - /string key| 85type space
		msg:id$ 85type forth:cr
639 640 641 642
		2drop
	    THEN
	LOOP
	r> to last#
643
    THEN ; msg-class is msg:otrify
Bernd Paysan's avatar
Bernd Paysan committed
644

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

648
\g 
Bernd Paysan's avatar
Bernd Paysan committed
649
\g ### group description commands ###
650
\g 
Bernd Paysan's avatar
Bernd Paysan committed
651

652
hash: group#
Bernd Paysan's avatar
Bernd Paysan committed
653 654 655

static-a to allocater
align here
656
groups-class new Constant group-o
Bernd Paysan's avatar
Bernd Paysan committed
657 658 659 660 661 662 663 664
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 )
665
    sample-group$ 2over group# #! last>o to groups:id$ ;
Bernd Paysan's avatar
Bernd Paysan committed
666 667 668 669 670 671 672

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
673
+net2o: group-id ( $:group -- ) \g group id, is a pubkey
Bernd Paysan's avatar
Bernd Paysan committed
674 675 676
    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
677 678
+net2o: group-admin ( $:adminkey -- ) \g set admin key
    group-o o = !!no-group-name!! $> groups:admin sec! ;
Bernd Paysan's avatar
Bernd Paysan committed
679 680 681 682 683 684 685 686 687 688 689 690
+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 )
691
    pk@ pkc swap move  sk@ skc swap move \ normalize pkc
Bernd Paysan's avatar
Bernd Paysan committed
692
    pkc keysize 3 * \ hash of pkc+pk1+skc keyed with "group"
Bernd Paysan's avatar
Bernd Paysan committed
693
    "group" keyed-hash#128 .chats/ ;
Bernd Paysan's avatar
Bernd Paysan committed
694 695

: read-chatgroups ( -- )
696
    0 ..chats/group [: type ." .v2o" ;] $tmp
Bernd Paysan's avatar
Bernd Paysan committed
697 698 699 700 701 702 703 704 705 706 707 708
    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
709
    groups:admin sec@ dup IF  sec$, group-admin  ELSE  2drop  THEN
Bernd Paysan's avatar
Bernd Paysan committed
710 711 712 713 714
    groups:perms# 64dup 64-0<> IF  lit, group-perms  ELSE  64drop  THEN
    o> ;

previous

715 716 717 718 719 720 721 722
: 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
723
: save-chatgroups ( -- )
724
    0 ..chats/group enc-filename $!
725
    [: group# ['] serialize-chatgroup #map ;] gen-cmd enc-file $!buf
Bernd Paysan's avatar
Bernd Paysan committed
726 727
    pk-off  key-list encfile-rest ;

728 729 730 731 732 733 734 735 736 737 738 739 740 741 742
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
743
: .chatgroup ( last# -- )
744 745
    dup $. space dup $@ rot cell+ $@ drop cell+ >o
    groups:id$ 2tuck str=
746 747
    IF  ." =" 2drop
    ELSE  ''' emit <info> 85type <default> ''' emit THEN space
Bernd Paysan's avatar
Bernd Paysan committed
748
    groups:member[] [: '@' emit .simple-id space ;] $[]map
Bernd Paysan's avatar
Bernd Paysan committed
749
\    ." admin " groups:admin[] [: '@' emit .simple-id space ;] $[]map
Bernd Paysan's avatar
Bernd Paysan committed
750 751 752
    ." +" groups:perms# x64.
    o> cr ;
: .chatgroups ( -- )
753 754
    groups>sort[]
    group-list[] $@ bounds ?DO  I @ .chatgroup  cell +LOOP ;
Bernd Paysan's avatar
Bernd Paysan committed
755

Bernd Paysan's avatar
Bernd Paysan committed
756 757 758 759
: ?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
760 761 762 763 764 765 766
: 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
767

768 769 770 771
\g 
\g ### messaging commands ###
\g 

Bernd Paysan's avatar
Bernd Paysan committed
772 773
scope{ net2o-base

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

778 779 780 781
msging-table >table

reply-table $@ inherit-table msging-table

bernd's avatar
bernd committed
782
$21 net2o: msg-group ( $:group -- ) \g set group
783
    $> >group ;
784
+net2o: msg-join ( $:group -- ) \g join a chat group
785
    $> >load-group parent >o
bernd's avatar
bernd committed
786
    +unique-con +chat-control
787
    wait-task @ ?dup-IF  <hide>  THEN
bernd's avatar
bernd committed
788
    o> ;
789
+net2o: msg-leave ( $:group -- ) \g leave a chat group
790
    $> >group parent msg-group-o .msg:peers[] del$cell ;
791
+net2o: msg-reconnect ( $:pubkey+addr -- ) \g rewire distribution tree
Bernd Paysan's avatar
Bernd Paysan committed
792
    $> $make
793
    <event last-msg 2@ e$, elit, o elit, msg-group-o elit, :>chat-reconnect
Bernd Paysan's avatar
Bernd Paysan committed
794
    parent .wait-task @ ?query-task over select event> ;
bernd's avatar
bernd committed
795 796
+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
797

798
net2o' nestsig net2o: msg-nestsig ( $:cmd+sig -- ) \g check sig+nest
Bernd Paysan's avatar
Bernd Paysan committed
799
    $> nest-sig ?dup-0=-IF
Bernd Paysan's avatar
Bernd Paysan committed
800
	handle-msg
Bernd Paysan's avatar
Bernd Paysan committed
801 802
    ELSE  replay-mode @ IF  drop  ELSE  !!sig!!  THEN
	2drop 2drop \ balk on all wrong signatures
Bernd Paysan's avatar
Bernd Paysan committed
803
    THEN ;
bernd's avatar
bernd committed
804

805 806
\ generate an encryt+sign packet

Bernd Paysan's avatar
Bernd Paysan committed
807
: ]encpksign ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
808 809 810
    +zero16 nest$
    0 msg-group-o .msg:keys[] $[]@ encrypt$
    ['] .encsign ']nestsig ;
811 812 813

\ nest-sig for msg/msging classes

814
' message msging-class is start-req
Bernd Paysan's avatar
Bernd Paysan committed
815
:noname check-date \ quicksig( check-date )else( pk-sig? )
816
    >r 2dup r> ; msging-class is nest-sig
817
' message msg-class is start-req
Bernd Paysan's avatar
Bernd Paysan committed
818
:noname 2dup msg-dec?-sig? ; msg-class is nest-sig
Bernd Paysan's avatar
Bernd Paysan committed
819

bernd's avatar
bernd committed
820 821
' context-table is gen-table

bernd's avatar
bernd committed
822
also }scope
bernd's avatar
bernd committed
823

Bernd Paysan's avatar
Bernd Paysan committed
824 825
msging-table $save

Bernd Paysan's avatar
Bernd Paysan committed
826
: msg-reply ( tag -- )
827
    ." got reply " hex. pubkey $@ key>nick forth:type forth:cr ;
Bernd Paysan's avatar
Bernd Paysan committed
828
: expect-msg ( o:connection -- )
829
    reply( ['] msg-reply )else( ['] drop ) expect-reply-xt +chat-control ;
Bernd Paysan's avatar
Bernd Paysan committed
830

bernd's avatar
bernd committed
831
User hashtmp$  hashtmp$ off
bernd's avatar
bernd committed
832

833 834
: last-msg@ ( -- ticks )
    last# >r
835 836
    last# $@ >group msg-group-o .msg:log[] $[]# ?dup-IF
	1- msg-group-o .msg:log[] $[]@ startdate@
837
    ELSE  64#0  THEN   r> to last# ;
bernd's avatar
bernd committed
838 839
: l.hashs ( end start -- hashaddr u )
    hashtmp$ $off
840 841
    msg-group-o .msg:log[] $[]# IF
	[: U+DO  I msg-group-o .msg:log[] $[]@ 1- dup 1 64s - safe/string forth:type
842 843 844 845
	  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
846
: i.date ( i -- )
847
    msg-group-o .msg:log[] $[]@ startdate@ 64#0 { 64^ x }
bernd's avatar
bernd committed
848
    x le-64! x 1 64s forth:type ;
849
: i.date+1 ( i -- )
850
    msg-group-o .msg:log[] $[]@ startdate@ 64#0 { 64^ x }
851
    64#1 64+ x le-64! x 1 64s forth:type ;
852
: last-msgs@ ( startdate enddate n -- addr u n' )
bernd's avatar
bernd committed
853 854 855 856 857
    \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
858 859
    last# >r >r last# $@ >group purge-log
    msg-group-o .msg:log[] $[]#
bernd's avatar
bernd committed
860
    IF
861
	date>i' >r date>i' r> swap
bernd's avatar
bernd committed
862
	2dup - r> over >r 1- 1 max / 0 max 1+ -rot
bernd's avatar
bernd committed
863
	[: over >r U+DO  I i.date
864
	      dup I + I' umin I l.hashs forth:type
865
	  dup +LOOP
866
	  r> dup msg-group-o .msg:log[] $[]# u< IF  i.date
867
	  ELSE  1- i.date+1  THEN
868
	  drop ;] $tmp r> \ over 1 64s u> -
869
    ELSE  rdrop 64drop 64drop s" "  0 THEN   r> to last# ;
870

bernd's avatar
bernd committed
871 872 873 874 875 876 877 878 879
\ 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
880
    state-addr >o  msgfs-class# fs-class! w/o fs-create o> ;
881
: .chat-file ( addr u -- )
bernd's avatar
bernd committed
882
    over le-64@ .ticks 1 64s /string  ." ->"
883 884
    over le-64@ .ticks 1 64s /string  ." @"
    .group ;
885
in net2o : copy-msg ( filename u -- )
bernd's avatar
bernd committed
886
    ." copy msg: " 2dup .chat-file forth:cr
bernd's avatar
bernd committed
887
    [: msgfs-class# ulit, file-type 2dup $, r/o ulit, open-sized-file
bernd's avatar
bernd committed
888
      file-reg# @ save-to-msg ;] n2o>file
bernd's avatar
bernd committed
889
    1 file-count +! ;
bernd's avatar
bernd committed
890

bernd's avatar
bernd committed
891
$20 Value max-last#
bernd's avatar
bernd committed
892 893 894
$20 Value ask-last#

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

bernd's avatar
bernd committed
896
: msg:last? ( start end n -- )
bernd's avatar
bernd committed
897
    last# $@ $, msg-group
bernd's avatar
bernd committed
898
    max-last# umin
899
    last-msgs@ >r $, r> ulit, msg-last ;
bernd's avatar
bernd committed
900
: ?ask-msg-files ( addr u -- )
bernd's avatar
bernd committed
901
    64#-1 64#0 { 64^ startd 64^ endd } \ byte order of 0 and -1 don't matter
902
    last# $@ >group
bernd's avatar
bernd committed
903 904
    $> bounds ?DO
	I' I 64'+ u> IF
905 906 907
	    I le-64@ date>i'
	    I 64'+ 64'+ le-64@ date>i' swap
	    l.hashs drop le-64@
908
	    I 64'+ le-64@ 64<> IF
909 910
		I 64@ startd le-64@ 64umin
		I 64'+ 64'+ 64@ endd le-64@ 64umax
911
	    ELSE
912 913 914 915 916 917
		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
918
	THEN
bernd's avatar
bernd committed
919
    2 64s +LOOP
bernd's avatar
bernd committed
920 921 922
    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
923 924 925 926
    THEN ;
: msg:last ( $:[tick0,tick1,...,tickn] n -- )
    last# >r  ask-msg-files[] $[]off
    forth:. ." Messages:" forth:cr
927
    ?ask-msg-files ask-msg-files[] $[]# IF
928
	parent >o  expect+slurp
bernd's avatar
bernd committed
929
	cmdbuf# @ 0= IF  $10 blocksize! $1 blockalign!  THEN
930
	ask-msg-files[] ['] net2o:copy-msg $[]map o>
931 932
    ELSE
	." === nothing to sync ===" forth:cr
Bernd Paysan's avatar
Bernd Paysan committed
933
	parent .sync-none-xt \ sync-nothing-xt???
934
    THEN
bernd's avatar
bernd committed
935
    r> to last# ;
bernd's avatar
bernd committed
936

bernd's avatar
bernd committed
937 938 939
:noname ( -- 64len )
    \ poll serializes the 
    fs-outbuf $off
940 941
    fs-path $@ 2 64s /string >group
    msg-log@ over >r
bernd's avatar
bernd committed
942
    fs-path $@ drop le-64@ date>i \ start index
943
    fs-path $@ drop 64'+ le-64@ 64#1 64+ date>i' \ end index
bernd's avatar
bernd committed
944
    over - >r
bernd's avatar
bernd committed
945
    cells safe/string r> cells umin
bernd's avatar
bernd committed
946
    req? @ >r req? off  serialize-log   r> req? !  fs-outbuf $!buf
bernd's avatar
bernd committed
947
    r> free throw
bernd's avatar
bernd committed
948 949
    fs-outbuf $@len u>64 ; msgfs-class is fs-poll
:noname ( addr u mode -- )
bernd's avatar
bernd committed
950
    \G addr u is starttick endtick name concatenated together
bernd's avatar
bernd committed
951
    fs-close drop fs-path $!  fs-poll fs-size!
bernd's avatar
bernd committed
952
    ['] noop is file-xt
bernd's avatar
bernd committed
953
; msgfs-class is fs-open
bernd's avatar
bernd committed
954 955

\ syncing done
956
: chat-sync-done ( group-addr u -- )
957
    msg( ." chat-sync-done " 2dup forth:type forth:cr )
958
    >group display-sync-done !save-all-msgs
Bernd Paysan's avatar
Bernd Paysan committed
959
    net2o-code expect-msg close-all net2o:gen-reset end-code
960
    net2o:close-all
961
    ." === sync done ===" forth:cr sync-done-xt ;
962
event: :>msg-eval ( parent $pack $addr -- )
963
    { w^ buf w^ group }
964
    group $@ 2 64s /string { d: gname }
965 966
    gname >group
    msg-group-o .msg:log[] $[]# u.
bernd's avatar
bernd committed
967
    buf $@ true replay-mode ['] msg-eval !wrapper
968
    buf $free ?save-msg
969
    group $@ .chat-file ."  saved "
970
    msg-group-o .msg:log[] $[]# u. forth:cr
971
    >o -1 file-count +!@ 1 =
972
    IF  gname chat-sync-done  THEN  group $free
973
    o> ;
bernd's avatar
bernd committed
974
: msg-file-done ( -- )
bernd's avatar
bernd committed
975
    fs-path $@len IF
976
	msg( ." msg file done: " fs-path $@ .chat-file forth:cr )
977
	['] fs-flush file-sema c-section
bernd's avatar
bernd committed
978
    THEN ;
bernd's avatar
bernd committed
979 980
:noname ( addr u mode -- )
    fs-close drop fs-path $!
bernd's avatar
bernd committed
981
    ['] msg-file-done is file-xt
bernd's avatar
bernd committed
982
; msgfs-class is fs-create
bernd's avatar
bernd committed
983 984 985
:noname ( addr u -- u )
    [ termserver-class :: fs-read ]
; msgfs-class is fs-read
bernd's avatar
bernd committed
986
:noname ( -- )
987
	<event parent elit, 0 fs-inbuf !@ elit,  0 fs-path !@ elit, :>msg-eval
988
	parent .wait-task @ event>
bernd's avatar
bernd committed
989
	fs:fs-clear
990 991 992 993 994 995
; 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
996
    THEN
bernd's avatar
bernd committed
997 998 999
; msgfs-class is fs-close
:noname ( perm -- )
    perm%msg and 0= !!msg-perm!!
1000
; msgfs-class is fs-perm?
bernd's avatar
bernd committed
1001 1002 1003 1004 1005
: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
1006 1007 1008

\ message composer

1009
: group, ( addr u -- )
bernd's avatar
bernd committed
1010
    $, msg-group ;
Bernd Paysan's avatar
Bernd Paysan committed
1011 1012 1013
: <msg ( -- )
    sign[ msg-group-o .msg:?lock IF  +zero16  THEN ;

bernd's avatar
bernd committed
1014
: msg> ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
1015
    \G end a message block by adding a signature
1016
    msg-group-o .msg:?lock IF  ]encpksign  ELSE  ]pksign  THEN ;
1017
: msg-otr> ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
1018
    \G end a message block by adding a short-time signature
Bernd Paysan's avatar
Bernd Paysan committed
1019
    now>otr msg> ;
bernd's avatar
bernd committed
1020 1021
: msg-log, ( -- addr u )
    last-signed 2@ >msg-log ;
bernd's avatar
bernd committed
1022 1023 1024

previous

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

bernd's avatar
bernd committed
1028
: last-signdate@ ( -- 64date )
1029
    msg-group-o .msg:log[] $@ dup IF
Bernd Paysan's avatar
Bernd Paysan committed
1030
	+ cell- $@ startdate@ 64#1 64+
bernd's avatar
bernd committed
1031 1032
    ELSE  2drop 64#-1  THEN ;

1033
also net2o-base
bernd's avatar
bernd committed
1034
: [msg,] ( xt -- )  last# >r
Bernd Paysan's avatar
Bernd Paysan committed
1035
    msg-group$ $@ dup IF  message ?destpk 2dup >group $,
bernd's avatar
bernd committed
1036 1037 1038 1039
	execute  end-with
    ELSE  2drop drop  THEN  r> to last# ;

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

: last?, ( -- )
Bernd Paysan's avatar
Bernd Paysan committed
1043
    last-signdate@ { 64: date }
1044
    64#0 lit, date lit, ask-last# ulit, msg-last?
bernd's avatar
bernd committed
1045
    date 64#-1 64<> IF
1046
	date lit, 64#-1 lit, 1 ulit, msg-last?
bernd's avatar
bernd committed
1047
    THEN ;
1048

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

bernd's avatar
bernd committed
1052
: join, ( -- )
1053
    [: msg-join sync-ahead?,
Bernd Paysan's avatar
Bernd Paysan committed
1054
      <msg msg-start "joined" $, msg-action msg-otr> ;] [msg,] ;
bernd's avatar
bernd committed
1055

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

bernd's avatar
bernd committed
1060
: leave, ( -- )
1061
    [: msg-leave
Bernd Paysan's avatar
Bernd Paysan committed
1062
      <msg msg-start "left" $, msg-action msg-otr> ;] [msg,] ;
1063

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

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