Check-in [1b953040cb]
Not logged in
Home Timeline Files Branches Tags Tickets Wiki Login Impressum Datenschutzerklärung

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

Overview
Comment:per-chat flags for OTR and similar
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1b953040cb4def65dd5083b779849ff78ff9e857
User & Date: bernd 2019-06-27 12:21:56
Context
2019-06-27
12:28
per-chat flags for OTR and similar check-in: 0a42fe7080 user: bernd tags: trunk
12:21
per-chat flags for OTR and similar check-in: 1b953040cb user: bernd tags: trunk
2019-06-24
11:23
add font-display auto check-in: bbae73269d user: bernd tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to classes.fs. 

127
128
129
130
131
132
133

134
135
136
137
138
139
140
141
142
143
144












145
146
147
148
149
150
151

    64field: time-offset  \ make timestamps smaller
    64field: lastdeltat
end-class ack-class

cmd-class class
    field: silent-last#
end-class msging-class


cmd-class class{ msg
    $10 +field dummy
    $value: name$ \ group name
    $value: id$
    field: peers[]
    field: keys[]
    field: log[]
    field: mode
    \ mode bits:
    0 5 bits: otr# chain# redate# lock# visible#












    method start
    method tag
    method chain
    method signal
    method re
    method text
    method object








>










|
>
>
>
>
>
>
>
>
>
>
>
>








127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164

    64field: time-offset  \ make timestamps smaller
    64field: lastdeltat
end-class ack-class

cmd-class class
    field: silent-last#
end-class msging-class


cmd-class class{ msg
    $10 +field dummy
    $value: name$ \ group name
    $value: id$
    field: peers[]
    field: keys[]
    field: log[]
    field: mode
    \ mode bits:
    1 5 bits: otr# chain# redate# lock# visible#
    : bit-ops: ( bit -- )
        parse-name [{: d: name :}l name rot [: emit type ;] $tmp nextname ;]
	{: xt: gen-name :}
	'+' gen-name create dup , [: @        mode or!  ;] set-does>
	'-' gen-name create dup , [: @ invert mode and! ;] set-does>
	'?' gen-name create     , [: @ mode @ and 0<>   ;] set-does> ;
    otr#     bit-ops: otr
    chain#   bit-ops: chain
    redate#  bit-ops: redate
    lock#    bit-ops: lock
    visible# bit-ops: visible

    method start
    method tag
    method chain
    method signal
    method re
    method text
    method object

Changes to cmd.fs. 

186
187
188
189
190
191
192
193
194
195
196
197
198
199
200

: n>cmd ( n -- addr ) cells >r
    o IF  token-table  ELSE  setup-table  THEN
    $@ r@ u<= !!function!! r> + ;

: cmd@ ( -- u ) buf-state 2@ over + >r p@+ r> over - buf-state 2! 64>n ;

standard:field
-7 cells 0 +field net2o.name
drop

: >net2o-name ( addr -- addr' u )
    net2o.name body> name>string ;
: >net2o-sig ( addr -- addr' u )
    net2o.name 3 cells + $@ ;
: .net2o-num ( off -- )  cell/ '<' emit 0 .r '>' emit space ;








|








186
187
188
189
190
191
192
193
194
195
196
197
198
199
200

: n>cmd ( n -- addr ) cells >r
    o IF  token-table  ELSE  setup-table  THEN
    $@ r@ u<= !!function!! r> + ;

: cmd@ ( -- u ) buf-state 2@ over + >r p@+ r> over - buf-state 2! 64>n ;

standard:field
vtsize negate 0 +field net2o.name
drop

: >net2o-name ( addr -- addr' u )
    net2o.name body> name>string ;
: >net2o-sig ( addr -- addr' u )
    net2o.name 3 cells + $@ ;
: .net2o-num ( off -- )  cell/ '<' emit 0 .r '>' emit space ;

Changes to do. 

1
2
3
4
5
6
7
8
9
10
11
12

#!/bin/bash

echo "This script builds net2o from scratch"

GFORTH=gforth-0.7.9_20190620

if [ "$(uname -o)" = "Cygwin" ]
then
    CONFOPT="--prefix=/usr $*"
else
    CONFOPT="$*"
fi





|








1
2
3
4
5
6
7
8
9
10
11
12

#!/bin/bash

echo "This script builds net2o from scratch"

GFORTH=gforth-0.7.9_20190627

if [ "$(uname -o)" = "Cygwin" ]
then
    CONFOPT="--prefix=/usr $*"
else
    CONFOPT="$*"
fi

Changes to gui.fs. 

995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009

    log free throw  msgs-box >o resized vp-bottom o>
    chat-edit engage ;

: gui-msgs ( gaddr u -- )
    2dup msg-group$ $! (gui-msgs) ;

: msg-wredisplay ( n -- )
    drop 0 otr-mode
    [: msg-group$ $@ (gui-msgs) ;] !wrapper
    msgs-box >o [: +sync +resize ;] vp-needed vp-bottom
    +sync +resize o>  ;
' msg-wredisplay wmsg-class is msg:redisplay

[IFDEF] android also android [THEN]









|








995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009

    log free throw  msgs-box >o resized vp-bottom o>
    chat-edit engage ;

: gui-msgs ( gaddr u -- )
    2dup msg-group$ $! (gui-msgs) ;

: msg-wredisplay ( n -- )
    drop 0 msg-group-o .msg:mode
    [: msg-group$ $@ (gui-msgs) ;] !wrapper
    msgs-box >o [: +sync +resize ;] vp-needed vp-bottom
    +sync +resize o>  ;
' msg-wredisplay wmsg-class is msg:redisplay

[IFDEF] android also android [THEN]

Changes to msg.fs. 

20
21
22
23
24
25
26


27
28
29


30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
...
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
...
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
....
1008
1009
1010
1011
1012
1013
1014
1015

1016
1017
1018
1019
1020
1021
1022
....
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
....
1316
1317
1318
1319
1320
1321
1322
1323

1324
1325
1326
1327



1328
1329
1330
1331
1332
1333

1334
1335
1336
1337
1338
1339
1340
1341
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
....
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563

Forward pk-connect? ( key u cmdlen datalen -- flag )
Forward addr-connect ( key+addr u cmdlen datalen xt -- )
Forward pk-peek? ( addr u0 -- flag )

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



: >group ( addr u -- )
    2dup msg-group# #@ d0= IF
	net2o:new-msg >o 2dup to msg:name$ o o>


	cell- [ msg-class >osize @ cell+ ]L
	2over msg-group# #!
    THEN  last# cell+ $@ drop cell+ to msg-group-o
    2drop ;

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

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

Sema queue-sema

\ peer queue, in msg context

: peer> ( -- addr / 0 )
    [: msg:peers[] back> ;] queue-sema c-section ;
................................................................................
: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-tdisplay ( addr u -- )
    sigpksize# - 2dup + sigpksize# >$  c-state off
    nest-cmd-loop msg:end ;
' msg-tdisplay msg-class is msg:display
' msg-tdisplay msg-notify-class is msg:display
: msg-tredisplay ( n -- )
    reset-time  0 otr-mode

    [:  cells >r msg-log@ 2dup { log u }
	dup r> - 0 max /string bounds ?DO
	    I log - cell/ to log#
	    I $@ { d: msgt }
	    msgt ['] msg:display catch IF  ." invalid entry" cr
		2drop  THEN
	cell +LOOP
................................................................................
    <warn> ." Type ctrl-D or '/bye' as single item to quit" <default> cr ;

: wait-2s-key ( -- )
    ntime 50 0 DO  key? ?LEAVE
    2dup i #40000000 um* d+ deadline  LOOP  2drop ;
: .nobody ( -- )
    <info>
    [: ." nobody's online" otr-mode @ 0= IF ." , saving away"  THEN ;] $tmp
    2dup type <default>
    wait-2s-key xclear ;

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

: ?chain, ( -- )  chain-mode @ 0= ?EXIT
    msg-group-o .msg:log[] $[]# 1- dup 0< IF  drop
    ELSE  msg-group-o .msg:log[] $[]@ chain,
    THEN ;

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

\ chat helper words

Variable chat-keys

................................................................................
    THEN
    [: $, msg-action ;] send-avalanche ;
synonym /back /away

: /otr ( addr u -- )
    \U otr on|off|message   turn otr mode on/off (or one-shot)
    2dup s" on" str= >r
    2dup s" off" str= r@ or IF   2drop r> otr-mode !

	<info> ." === " otr-mode @ IF  ." enter"  ELSE  ." leave"  THEN
	."  otr mode ===" <default> forth:cr
    ELSE  rdrop
	true otr-mode !@ >r  avalanche-text  r> otr-mode !



    THEN ;

: /chain ( addr u -- )
    \U chain on|off         turn chain mode on/off
    2dup s" on" str= >r
    s" off" str= r@ or IF   r> chain-mode !

	<info> ." === " chain-mode @ IF  ." enter"  ELSE  ." leave"  THEN
	."  chain mode ==="
    ELSE  <err> ." only 'chain on|off' are allowed" rdrop  THEN
    <default> forth:cr ;

: /peers ( addr u -- ) 2drop
    \U peers                list peers
    \G peers: list peers in all groups
................................................................................
    \G logstyle: +date      a date per log line
    \G logstyle: +num       a message number per log line
    ['] logstyles evaluate-in ;

: /otrify ( addr u -- )
    \U otrify #line[s]      otrify message
    \G otrify: turn an older message of yours into an OTR message
    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

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









>
>


|
>
>













<
<
<
<







 







|







 







|


|







 







|
>







 







|









|









|







 







|
>
|


<
>
>
>





|
>
|







 







|












|



|







 







|








20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46




47
48
49
50
51
52
53
...
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
...
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
....
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
....
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
....
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328

1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
....
1451
1452
1453
1454
1455
1456
1457
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
....
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568

Forward pk-connect? ( key u cmdlen datalen -- flag )
Forward addr-connect ( key+addr u cmdlen datalen xt -- )
Forward pk-peek? ( addr u0 -- flag )

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

Variable otr-mode \ global otr mode

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

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

Variable msg-group$




Variable msg-keys[]
User replay-mode
User skip-sig?

Sema msglog-sema

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

Sema queue-sema

\ peer queue, in msg context

: peer> ( -- addr / 0 )
    [: msg:peers[] back> ;] queue-sema c-section ;
................................................................................
:noname ( addr u -- ) $utf8> forth:type ; msg-class is msg:text
:noname ( addr u -- ) $utf8>
    <warn> forth:type <default> ; msg-class is msg:url
:noname ( xchar -- )
    <info> utf8emit <default> ; msg-class is msg:like
:noname ( addr u -- )
    0 .v-dec$ dup IF
	msg-key!  msg-group-o .msg:+lock
    ELSE  2drop  THEN
    <info> ." chat is locked" <default> ;   msg-class is msg:lock
:noname ( -- )  msg-group-o .msg:-lock
    <info> ." chat is free for all" <default> ; msg-class is msg:unlock
' drop msg-class is msg:away
: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-tdisplay ( addr u -- )
    sigpksize# - 2dup + sigpksize# >$  c-state off
    nest-cmd-loop msg:end ;
' msg-tdisplay msg-class is msg:display
' msg-tdisplay msg-notify-class is msg:display
: msg-tredisplay ( n -- )
    reset-time
    msg-group-o .msg:mode dup @ msg:otr# invert and swap
    [:  cells >r msg-log@ 2dup { log u }
	dup r> - 0 max /string bounds ?DO
	    I log - cell/ to log#
	    I $@ { d: msgt }
	    msgt ['] msg:display catch IF  ." invalid entry" cr
		2drop  THEN
	cell +LOOP
................................................................................
    <warn> ." Type ctrl-D or '/bye' as single item to quit" <default> cr ;

: wait-2s-key ( -- )
    ntime 50 0 DO  key? ?LEAVE
    2dup i #40000000 um* d+ deadline  LOOP  2drop ;
: .nobody ( -- )
    <info>
    [: ." nobody's online" msg-group-o .msg:?otr 0= IF ." , saving away"  THEN ;] $tmp
    2dup type <default>
    wait-2s-key xclear ;

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

: ?chain, ( -- )  msg-group-o .msg:?chain 0= ?EXIT
    msg-group-o .msg:log[] $[]# 1- dup 0< IF  drop
    ELSE  msg-group-o .msg:log[] $[]@ chain,
    THEN ;

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

\ chat helper words

Variable chat-keys

................................................................................
    THEN
    [: $, msg-action ;] send-avalanche ;
synonym /back /away

: /otr ( addr u -- )
    \U otr on|off|message   turn otr mode on/off (or one-shot)
    2dup s" on" str= >r
    2dup s" off" str= r@ or IF   2drop
	msg-group-o r@ IF  .msg:+otr  ELSE  .msg:-otr  THEN
	<info> ." === " r> IF  ." enter"  ELSE  ." leave"  THEN
	."  otr mode ===" <default> forth:cr
    ELSE  rdrop

	msg-group-o .msg:mode @ >r
	msg-group-o .msg:+otr avalanche-text
	r> msg-group-o .msg:mode !
    THEN ;

: /chain ( addr u -- )
    \U chain on|off         turn chain mode on/off
    2dup s" on" str= >r
    s" off" str= r@ or IF
	msg-group-o r@ IF  .msg:+chain  ELSE  .msg:-chain  THEN
	<info> ." === " r> IF  ." enter"  ELSE  ." leave"  THEN
	."  chain mode ==="
    ELSE  <err> ." only 'chain on|off' are allowed" rdrop  THEN
    <default> forth:cr ;

: /peers ( addr u -- ) 2drop
    \U peers                list peers
    \G peers: list peers in all groups
................................................................................
    \G logstyle: +date      a date per log line
    \G logstyle: +num       a message number per log line
    ['] logstyles evaluate-in ;

: /otrify ( addr u -- )
    \U otrify #line[s]      otrify message
    \G otrify: turn an older message of yours into an OTR message
    msg:otr# msg-group-o .msg: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[] $+[]!
    msg-group-o .msg:+lock ;
: /unlock ( addr u -- )
    \U unlock               stop lock down
    \G unlock: stop lock down
    2drop msg-group-o .msg:-lock ;

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

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

Fossil 2.9 [c9eb81a550] 2019-08-28 10:41:56