Check-in [985b47981c]
Not logged in

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

Overview
Comment:Add better chain support
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 985b47981cab9b74a7ec11a02079317ebab6b517
User & Date: bernd 2019-07-05 14:51:28
Context
2019-07-05
15:01
Add better chain support check-in: 8afee7be22 user: bernd tags: trunk
14:51
Add better chain support check-in: 985b47981c user: bernd tags: trunk
2019-07-04
21:50
Start implementing commands in GUI mode check-in: 581eb4c544 user: bernd tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to classes.fs.

   138    138       $value: name$ \ group name
   139    139       $value: id$
   140    140       field: peers[]
   141    141       field: keys[]
   142    142       field: log[]
   143    143       field: mode
   144    144       \ mode bits:
   145         -    1 5 bits: otr# chain# redate# lock# visible#
          145  +    1 4 bits: otr# redate# lock# visible#
   146    146       : bit-ops: ( bit -- )
   147    147           parse-name [{: d: name :}l name rot [: emit type ;] $tmp nextname ;]
   148    148   	{: xt: gen-name :}
   149    149   	'+' gen-name create dup , [: @        mode or!  ;] set-does>
   150    150   	'-' gen-name create dup , [: @ invert mode and! ;] set-does>
   151    151   	'?' gen-name create     , [: @ mode @ and 0<>   ;] set-does> ;
   152    152       otr#     bit-ops: otr
   153         -    chain#   bit-ops: chain
   154    153       redate#  bit-ops: redate
   155    154       lock#    bit-ops: lock
   156    155       visible# bit-ops: visible
   157    156   
   158    157       method start
   159    158       method tag
   160    159       method chain

Changes to gui.fs.

   406    406   $33883366 new-color: day-color
   407    407   $88333366 new-color: hour-color
   408    408   $FFFFFFFF text-color: realwhite
   409    409   $FFFFFFFF new-color: edit-bg
   410    410   $80FF80FF new-color: send-color
   411    411   $00FF0020 new-color: pet-color
   412    412   $FFFF80FF new-color, fvalue users-color#
          413  +$FFCCCCFF new-color, fvalue gps-color#
          414  +$000077FF new-color, fvalue chain-color#
   413    415   
   414    416   : nick[] ( box o:nick -- box )
   415    417       [: data >o ." clicked on " ke-nick $. cr o> ;] o click[] ;
   416    418   
   417    419   Hash: avatar#
   418    420   
   419    421   glue new Constant glue*avatar
................................................................................
   886    888       [: data >o text$ o> open-url ;]
   887    889       over click[]
   888    890       click( ." url: " dup ..parents cr )
   889    891       "url" name! msg-box .child+
   890    892   ; wmsg-class to msg:url
   891    893   :noname { d: string -- o }
   892    894       {{
   893         -	glue*l $FFCCCCFF new-color, slide-frame dup .button1
          895  +	glue*l gps-color# slide-frame dup .button1
   894    896   	string [: ."  GPS: " .coords ;] $tmp }}text 25%b
   895    897       }}z "gps" name! msg-box .child+
   896    898   ; wmsg-class to msg:coord
          899  +:noname { d: string -- o }
          900  +    {{
          901  +	glue*l chain-color# slide-frame dup .button1
          902  +	string sighash? IF  re-green  ELSE  obj-red  THEN
          903  +	string [: ." <" drop le-64@ .ticks ;] $tmp }}text 25%b
          904  +    }}z "chain" name! msg-box .child+
          905  +; wmsg-class to msg:chain
   897    906   :noname { d: pk -- o }
   898    907       {{
   899    908   	x-color { f: xc }
   900    909   	pk key|
   901    910   	2dup 0 .pk@ key| str=
   902    911   	last-otr? IF  IF  my-signal-otr  ELSE  other-signal-otr  THEN
   903    912   	ELSE  IF  my-signal  ELSE  other-signal  THEN  THEN

Changes to msg.fs.

   343    343   $20 net2o: msg-start ( $:pksig -- ) \g start message
   344    344       1 !!>order? $> msg:start ;
   345    345   +net2o: msg-tag ( $:tag -- ) \g tagging (can be anywhere)
   346    346       $> msg:tag ;
   347    347   +net2o: msg-id ( $:id -- ) \g a hash id
   348    348       2 !!>=order? $> msg:id ;
   349    349   +net2o: msg-chain ( $:dates,sighash -- ) \g chained to message[s]
   350         -    $10 !!>=order? $> msg:chain ;
          350  +    ( $10 !!>=order? ) $> msg:chain ;
   351    351   +net2o: msg-signal ( $:pubkey -- ) \g signal message to one person
   352    352       $> msg:signal ;
   353    353   +net2o: msg-re ( $:hash ) \g relate to some object
   354    354       4 !!>=order? $> msg:re ;
   355    355   +net2o: msg-text ( $:msg -- ) \g specify message string
   356    356       8 !!>=order? $> msg:text ;
   357    357   +net2o: msg-object ( $:object type -- ) \g specify an object, e.g. an image
................................................................................
  1165   1165   
  1166   1166   also net2o-base
  1167   1167   \ chain messages to one previous message
  1168   1168   : chain, ( msgaddr u -- )
  1169   1169       [: 2dup startdate@ 64#0 { 64^ sd } sd le-64!  sd 1 64s forth:type
  1170   1170   	c:0key sigonly@ >hash hashtmp hash#128 forth:type ;] $tmp $, msg-chain ;
  1171   1171   
  1172         -: ?chain, ( -- )  msg-group-o .msg:?chain 0= ?EXIT
  1173         -    msg-group-o .msg:log[] $[]# 1- dup 0< IF  drop
  1174         -    ELSE  msg-group-o .msg:log[] $[]@ chain,
  1175         -    THEN ;
  1176         -
  1177   1172   : (send-avalanche) ( xt -- addr u flag )
  1178         -    [: 0 >o [: sign[ msg-start execute ?chain, msg> ;] gen-cmd$ o>
         1173  +    [: 0 >o [: sign[ msg-start execute msg> ;] gen-cmd$ o>
  1179   1174         +last-signed msg-log, ;] [group] ;
  1180   1175   previous
  1181   1176   : send-avalanche ( xt -- )
  1182   1177       msg-group-o .msg:?otr IF  now>otr  ELSE  now>never  THEN
  1183   1178       (send-avalanche)
  1184   1179       >r .chat r> 0= IF  .nobody  THEN ;
  1185   1180   
................................................................................
  1310   1305       \G me: send remaining string as action
  1311   1306   umethod /away ( addr u -- )
  1312   1307       \U away [<action>]      send string or "away from keyboard" as action
  1313   1308       \G away: send string or "away from keyboard" as action
  1314   1309   synonym /back /away
  1315   1310   umethod /otr ( addr u -- )
  1316   1311       \U otr on|off|message   turn otr mode on/off (or one-shot)
  1317         -umethod /chain ( addr u -- )
  1318         -    \U chain on|off         turn chain mode on/off
  1319   1312   umethod /peers ( addr u -- )
  1320   1313       \U peers                list peers
  1321   1314       \G peers: list peers in all groups
  1322   1315   umethod /gps ( addr u -- )
  1323   1316       \U gps                  send coordinates
  1324   1317       \G gps: send your coordinates
  1325   1318   synonym /here /gps
................................................................................
  1411   1404   	."  otr mode ===" <default> forth:cr
  1412   1405       ELSE  rdrop
  1413   1406   	msg-group-o .msg:mode @ >r
  1414   1407   	msg-group-o .msg:+otr avalanche-text
  1415   1408   	r> msg-group-o .msg:mode !
  1416   1409       THEN ; is /otr
  1417   1410   
  1418         -:noname ( addr u -- )
  1419         -    2dup s" on" str= >r
  1420         -    s" off" str= r@ or IF
  1421         -	msg-group-o r@ IF  .msg:+chain  ELSE  .msg:-chain  THEN
  1422         -	<info> ." === " r> IF  ." enter"  ELSE  ." leave"  THEN
  1423         -	."  chain mode ==="
  1424         -    ELSE  <err> ." only 'chain on|off' are allowed" rdrop  THEN
  1425         -    <default> forth:cr ; is /chain
  1426         -
  1427   1411   :noname ( addr u -- )  2drop
  1428   1412       [: msg:name$ .group ." : "
  1429   1413   	msg:peers[] $@ bounds ?DO
  1430   1414   	    space I @ >o .con-id space
  1431   1415   	    ack@ .rtdelay 64@ 64>f 1n f* (.time) o>
  1432   1416   	cell +LOOP  forth:cr ;] group#map ; is /peers
  1433   1417   
................................................................................
  1556   1540   	    2>r over ?flush-text + to last->in  2r>
  1557   1541   	    [:
  1558   1542   		\ ." signal: '" 85type ''' forth:emit forth:cr
  1559   1543   		$, msg-signal
  1560   1544   	    ;] rectype-name
  1561   1545   	THEN
  1562   1546       ELSE  2drop rectype-null  THEN ;
         1547  +: chain-rec ( addr u -- )
         1548  +    over c@ '!' = IF
         1549  +	2dup 1 /string dup 0= IF  2drop rectype-null  EXIT  THEN
         1550  +	snumber?
         1551  +	case
         1552  +	    0 of  endof
         1553  +	    -1 of
         1554  +		msg-group-o .msg:log[] $[]#
         1555  +		over abs over u< IF  over 0< IF  +  ELSE  drop  THEN
         1556  +		    >r over ?flush-text + to last->in  r>
         1557  +		    [: msg-group-o .msg:log[] $[]@ chain, ;]
         1558  +		    rectype-name  EXIT  THEN
         1559  +	    endof
         1560  +	    2drop
         1561  +	endcase
         1562  +    THEN  2drop  rectype-null  ;
  1563   1563   : http-rec ( addr u -- )
  1564   1564       2dup "https://" string-prefix? >r
  1565   1565       2dup "http://" string-prefix? r> or IF
  1566   1566   	over ?flush-text 2dup + to last->in
  1567   1567   	[: $, msg-url ;] rectype-name
  1568   1568       ELSE  2drop rectype-null  THEN ;
  1569   1569   
  1570   1570   $Variable msg-recognizer
  1571         -' text-rec ' http-rec ' tag-rec ' pk-rec 4 msg-recognizer set-stack
         1571  +' text-rec ' http-rec ' chain-rec ' tag-rec ' pk-rec 5 msg-recognizer set-stack
  1572   1572   
  1573   1573   : parse-text ( addr u -- ) last# >r  forth-recognizer >r
  1574   1574       0 to last->in
  1575   1575       msg-recognizer to forth-recognizer 2dup evaluate
  1576   1576       last->in IF  + last->in tuck -  THEN  dup IF
  1577   1577   	\ ." text: '" forth:type ''' forth:emit forth:cr
  1578   1578   	$, msg-text