Check-in [2d8a974f37]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Some more work on locking down chats
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 2d8a974f37d968d30d45f00d3a8a73d3b29eee1f
User & Date: bernd 2019-06-12 21:37:39
Context
2019-06-17
23:00
Group context handling changed check-in: 5cb84dae88 user: bernd tags: trunk
2019-06-12
21:37
Some more work on locking down chats check-in: 2d8a974f37 user: bernd tags: trunk
2019-06-10
21:41
Add code to hide messages in open chat log check-in: 9a4250484f user: bernd tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to classes.fs.

125
126
127
128
129
130
131

132
133
134
135
136
137
138
139
140
141
142
...
147
148
149
150
151
152
153


154
155
156
157
158
159
160
    64field: min-slack
    64field: max-slack
    64field: time-offset  \ make timestamps smaller
    64field: lastdeltat
end-class ack-class

cmd-class class

    field: peers[]
    field: msg-keys[]
    field: silent-last#
    method dec-nest-sig \ check sig, decrypt and then nest
end-class msging-class

cmd-class class{ msg
    $value: id$
    method start
    method tag
    method chain
................................................................................
    method id
    method action
    method coord
    method otrify
    method payment
    method url
    method like


    method away
    method end
    method display   \ display one message
    method redisplay \ display full set
}class

cmd-class class{ pay







>

<

<







 







>
>







125
126
127
128
129
130
131
132
133

134

135
136
137
138
139
140
141
...
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
    64field: min-slack
    64field: max-slack
    64field: time-offset  \ make timestamps smaller
    64field: lastdeltat
end-class ack-class

cmd-class class
    $value: msging-id$
    field: peers[]

    field: silent-last#

end-class msging-class

cmd-class class{ msg
    $value: id$
    method start
    method tag
    method chain
................................................................................
    method id
    method action
    method coord
    method otrify
    method payment
    method url
    method like
    method lock
    method unlock
    method away
    method end
    method display   \ display one message
    method redisplay \ display full set
}class

cmd-class class{ pay

Changes to keys.fs.

1433
1434
1435
1436
1437
1438
1439




1440
1441
1442
1443
1444
1445
1446
    \G this version of get-me fails hard if no key is opened
    get-my-key catch
    case
	#-56 of .keyinfo true !!no-key-open!! endof
	#-28 of .keyinfo true !!no-key-open!! endof
	throw  0
    endcase ;





\\\
Local Variables:
forth-local-words:
    (
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))







>
>
>
>







1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
    \G this version of get-me fails hard if no key is opened
    get-my-key catch
    case
	#-56 of .keyinfo true !!no-key-open!! endof
	#-28 of .keyinfo true !!no-key-open!! endof
	throw  0
    endcase ;

: args>keylist ( -- )
    [: nick-key ?dup-IF  >o ke-pk $@ o> keysize umin key-list $+[]!  THEN ;]
    @arg-loop ;

\\\
Local Variables:
forth-local-words:
    (
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))

Changes to msg.fs.

36
37
38
39
40
41
42


43
44
45
46
47
48
49
...
324
325
326
327
328
329
330




331
332
333
334
335
336
337
...
362
363
364
365
366
367
368




369
370
371
372
373
374
375
...
409
410
411
412
413
414
415


416
417
418
419
420
421
422
...
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
...
443
444
445
446
447
448
449







450
451
452
453
454
455
456
...
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
....
1441
1442
1443
1444
1445
1446
1447












1448
1449
1450
1451
1452
1453
1454

Variable msg-group$
Variable group-master
Variable msg-logs
Variable otr-mode
Variable chain-mode
Variable redate-mode


User replay-mode
User skip-sig?

Sema msglog-sema

: ?msg-context ( -- o )
    msging-context @ dup 0= IF
................................................................................
    r> r> U+DO
	c:0key I last# cell+ $[]@ sigonly@ >hash
	2dup hashtmp over str= IF  2drop true  UNLOOP   EXIT
	ELSE  ( 2dup 85type ."  <> " hashtmp over 85type )  THEN
    LOOP
    2drop false ;





\ message commands

scope{ net2o-base

\g 
\g ### message commands ###
\g 
................................................................................
    $> $> 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 ;





}scope

msg-table $save

' context-table is gen-table

................................................................................
; 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


' 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 -- )
................................................................................
    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 pk@ key| str=
    IF   <err>  THEN ." @" .key-id? <default>
    r> to last# ; msg-class is msg:signal
:noname ( addr u -- )
    last# >r last# $@ ?msg-log
    2dup sighash? IF  <info>  ELSE  <err>  THEN
    ."  <" over le-64@ .ticks
    verbose( dup keysize - /string ." ," 85type )else( 2drop ) <default>
................................................................................
: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







' drop msg-class is msg:away
: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
................................................................................
	parent last# cell+ del$cell  THEN ;
+net2o: msg-reconnect ( $:pubkey+addr -- ) \g rewire distribution tree
    $> $make
    <event last-msg 2@ e$, elit, o elit, last# 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: msg-key ( $:key -- )
    $> v-dec$ dup IF  msg-keys[] $+[]!  ELSE  2drop  THEN ;

net2o' nestsig net2o: msg-nestsig ( $:cmd+sig -- ) \g check sig+nest
    $> nest-sig ?dup-0=-IF
	handle-msg
   ELSE  replay-mode @ IF  drop 2drop
	ELSE  !!sig!!  THEN \ balk on all wrong signatures
    THEN ;
................................................................................
    true otr-mode [: now>otr
	[: BEGIN  bl $split 2>r dup  WHILE  s>unumber? WHILE
			drop do-otrify  2r>  REPEAT THEN
	    2drop 2r> 2drop
	;] (send-avalanche) drop .chat save-msgs&
    ;] !wrapper ;













: /bye ( addr u -- )
    \U bye
    \G bye: leaves the current chat
    2drop -1 [IFDEF] android android:level# [ELSE] level# [THEN] +! ;
}scope

: ?slash ( addr u -- addr u flag )







>
>







 







>
>
>
>







 







>
>
>
>







 







>
>







 







|







 







>
>
>
>
>
>
>







 







<
<







 







>
>
>
>
>
>
>
>
>
>
>
>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
...
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
...
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
...
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
...
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
...
666
667
668
669
670
671
672


673
674
675
676
677
678
679
....
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483

Variable msg-group$
Variable group-master
Variable msg-logs
Variable otr-mode
Variable chain-mode
Variable redate-mode
Variable lock-mode
Variable msg-keys[]
User replay-mode
User skip-sig?

Sema msglog-sema

: ?msg-context ( -- o )
    msging-context @ dup 0= IF
................................................................................
    r> r> U+DO
	c:0key I last# cell+ $[]@ 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-keys[] [: rot >r 2over str= r> or ;] $[]map
    IF  2drop  ELSE  msg-keys[] $+[]!  THEN ;

\ message commands

scope{ net2o-base

\g 
\g ### message commands ###
\g 
................................................................................
    $> $> 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 ( -- )
    msg:unlock ;

}scope

msg-table $save

' context-table is gen-table

................................................................................
; 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
' 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 -- )
................................................................................
    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# $@ ?msg-log
    2dup sighash? IF  <info>  ELSE  <err>  THEN
    ."  <" over le-64@ .ticks
    verbose( dup keysize - /string ." ," 85type )else( 2drop ) <default>
................................................................................
: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!  lock-mode on
    ELSE  2drop  THEN
    <info> ." chat is locked" <default> ;   msg-class is msg:lock
:noname ( -- )  lock-mode off
    <info> ." chat is free for all" <default> ; msg-class is msg:unlock
' drop msg-class is msg:away
: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
................................................................................
	parent last# cell+ del$cell  THEN ;
+net2o: msg-reconnect ( $:pubkey+addr -- ) \g rewire distribution tree
    $> $make
    <event last-msg 2@ e$, elit, o elit, last# 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 2drop
	ELSE  !!sig!!  THEN \ balk on all wrong signatures
    THEN ;
................................................................................
    true otr-mode [: now>otr
	[: BEGIN  bl $split 2>r dup  WHILE  s>unumber? WHILE
			drop do-otrify  2r>  REPEAT THEN
	    2drop 2r> 2drop
	;] (send-avalanche) drop .chat save-msgs&
    ;] !wrapper ;

: /lock ( addr u -- )
    \U lock {@nick}         lock down
    \G lock: lock down communication to list of nicks
    word-args ['] args>keylist execute-parsing
    [: key-list v-enc$ $, net2o-base:msg-lock ;] send-avalanche
    vkey keysize msg-keys[] ~~ $+[]!
    lock-mode on ;
: /unlock ( addr u -- )
    \U unlock               stop lock down
    \G unlock: stop lock down
    2drop lock-mode off ;

: /bye ( addr u -- )
    \U bye
    \G bye: leaves the current chat
    2drop -1 [IFDEF] android android:level# [ELSE] level# [THEN] +! ;
}scope

: ?slash ( addr u -- addr u flag )

Changes to n2o.fs.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
\ 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/>.

require net2o.fs

Variable key-readin

: out-nicks ( -- )
    [: nick-key ?dup-IF  out-key  THEN ;] @arg-loop ;

: qr-me ( -- ) pk@ qr:ownkey# .keyqr ;
: qr-nicks ( -- )
    [: nick-key ?dup-IF  >o ke-pk $@
	    qr:ownkey# qr:key# ke-sk sec@ nip select o>
	    .keyqr  THEN ;] @arg-loop ;

: args>keylist ( -- )
    [: nick-key ?dup-IF  >o ke-pk $@ o> keysize umin key-list $+[]!  THEN ;]
    @arg-loop ;

$20 value hash-size#

: hash-file ( addr u -- hash u' )
    c:0key slurp-file 2dup c:hash drop free throw pad c:key>
    pad hash-size# ;








<
<
<






|
<
|







15
16
17
18
19
20
21



22
23
24
25
26
27
28

29
30
31
32
33
34
35
36
\ 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/>.

require net2o.fs

Variable key-readin




: qr-me ( -- ) pk@ qr:ownkey# .keyqr ;
: qr-nicks ( -- )
    [: nick-key ?dup-IF  >o ke-pk $@
	    qr:ownkey# qr:key# ke-sk sec@ nip select o>
	    .keyqr  THEN ;] @arg-loop ;

: out-nicks ( -- )

    [: nick-key ?dup-IF  out-key  THEN ;] @arg-loop ;

$20 value hash-size#

: hash-file ( addr u -- hash u' )
    c:0key slurp-file 2dup c:hash drop free throw pad c:key>
    pad hash-size# ;