Check-in [7c40ba825d]
Not logged in

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

Overview
Comment:Start syncing old messages
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 7c40ba825d1e459ca6133ae5d659bb2c9cc674db
User & Date: bernd 2016-08-04 01:35:40
Context
2016-08-04
15:17
Bump version number check-in: 7c128e8914 user: bernd tags: trunk, 0.1.7-20160804
01:35
Start syncing old messages check-in: 7c40ba825d user: bernd tags: trunk
2016-08-03
20:42
A few small fixes check-in: 0b728593bb user: bernd tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to net2o-file.fs.

176
177
178
179
180
181
182
183

184
185
186
187
188
189
190
191
192
193
194
195
196
197

198
199
200
201
202
203
204
...
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
...
256
257
258
259
260
261
262
263



264
265
266
267
268



269
270
271
272
273
274
275
\ subclassing for other sorts of files

fs-class class
end-class socket-class

:noname ( addr u port -- ) fs-close 64>n
    msg( dup 2over ." open socket: " type ."  with port " . cr )
    open-socket fs-fid ! 64#0 fs-size! ; socket-class to fs-open

:noname ( -- size )
    fs-fid @ fileno check_read dup 0< IF  -512 + throw  THEN
    n>64 fs-size 64@ 64+ ; socket-class to fs-poll
:noname ( perm -- )
    perm%socket and 0= !!socket-perm!!
; socket-class to fs-perm?

fs-class class
end-class termclient-class

:noname ( addr u -- u ) tuck type ; termclient-class to fs-write
:noname ( addr u -- u ) 0 -rot bounds ?DO
	key? 0= ?LEAVE  key I c! 1+  LOOP ; termclient-class to fs-read
:noname ( addr u 64n -- ) 64drop 2drop ; termclient-class to fs-open

:noname ( -- ) ; termclient-class to fs-close
:noname ( perm -- )
    perm%terminal and 0= !!terminal-perm!!
; termclient-class to fs-perm?

termclient-class class
end-class termserver-class
................................................................................
    fs-outbuf $@ r@ umin rot swap move
    fs-outbuf 0 r@ $del r> ; termserver-class to fs-read
:noname ( addr u 64n -- )  64drop 2drop
    [: termserver-tasks $@ 0= !!no-termserver!!
	@ termserver-tasks 0 cell $del dup fs-termtask !
	<event o elit, ->termfile event>
    ;] file-sema c-section
; termserver-class to fs-open
:noname ( -- )
    [: fs-termtask @ ?dup-IF
	    <event ->termclose event>
	    fs-termtask cell termserver-tasks $+! fs-termtask off
	THEN ;] file-sema c-section
; termserver-class to fs-close
:noname ( perm -- )
................................................................................
Create file-classes
fs-class ,
hashfs-class ,
socket-class ,
termclient-class ,
termserver-class ,

here file-classes - cell/ Constant file-classes#




: fs-class! ( n -- )
    dup file-classes# u>= !!fileclass!!
    cells file-classes + @ o cell- ! ;




\ state handling

scope{ mapc

: dest-top! ( addr -- )
    \ dest-tail @ dest-size @ + umin
    dup dup dest-top @ U+DO







|
>













|
>







 







|







 







|
>
>
>





>
>
>







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
...
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
\ subclassing for other sorts of files

fs-class class
end-class socket-class

:noname ( addr u port -- ) fs-close 64>n
    msg( dup 2over ." open socket: " type ."  with port " . cr )
    open-socket fs-fid ! 64#0 fs-size! ;
dup socket-class to fs-open  socket-class to fs-create
:noname ( -- size )
    fs-fid @ fileno check_read dup 0< IF  -512 + throw  THEN
    n>64 fs-size 64@ 64+ ; socket-class to fs-poll
:noname ( perm -- )
    perm%socket and 0= !!socket-perm!!
; socket-class to fs-perm?

fs-class class
end-class termclient-class

:noname ( addr u -- u ) tuck type ; termclient-class to fs-write
:noname ( addr u -- u ) 0 -rot bounds ?DO
	key? 0= ?LEAVE  key I c! 1+  LOOP ; termclient-class to fs-read
:noname ( addr u 64n -- ) 64drop 2drop ;
dup termclient-class to fs-open  termclient-class to fs-create
:noname ( -- ) ; termclient-class to fs-close
:noname ( perm -- )
    perm%terminal and 0= !!terminal-perm!!
; termclient-class to fs-perm?

termclient-class class
end-class termserver-class
................................................................................
    fs-outbuf $@ r@ umin rot swap move
    fs-outbuf 0 r@ $del r> ; termserver-class to fs-read
:noname ( addr u 64n -- )  64drop 2drop
    [: termserver-tasks $@ 0= !!no-termserver!!
	@ termserver-tasks 0 cell $del dup fs-termtask !
	<event o elit, ->termfile event>
    ;] file-sema c-section
; dup termserver-class to fs-open  termserver-class to fs-create
:noname ( -- )
    [: fs-termtask @ ?dup-IF
	    <event ->termclose event>
	    fs-termtask cell termserver-tasks $+! fs-termtask off
	THEN ;] file-sema c-section
; termserver-class to fs-close
:noname ( perm -- )
................................................................................
Create file-classes
fs-class ,
hashfs-class ,
socket-class ,
termclient-class ,
termserver-class ,

here file-classes - cell/
$10 over - cells allot

Value file-classes#

: fs-class! ( n -- )
    dup file-classes# u>= !!fileclass!!
    cells file-classes + @ o cell- ! ;

: +file-classes ( addr -- )
    file-classes file-classes# dup 1+ to file-classes# cells + ! ;

\ state handling

scope{ mapc

: dest-top! ( addr -- )
    \ dest-tail @ dest-size @ + umin
    dup dup dest-top @ U+DO

Changes to net2o-msg.fs.

53
54
55
56
57
58
59
60
61
62
63
64
65
66




67
68
69
70
71
72

73
74
75
76
77
78
79
80
...
379
380
381
382
383
384
385

















386
387
388
389
390
391
392
393
394


























395
396
397
398
399
400
401
    THEN ;

: >chatid ( group u -- id u )  defaultkey sec@ keyed-hash#128 ;

: msg-log@ ( last# -- addr u )
    [: cell+ $@ save-mem ;] msglog-sema c-section ;

: save-msgs ( last -- )
    ?.net2o/chats  n2o:new-msging >o enc-file $off
    dup msg-log@ over >r
    [: bounds ?DO
	  I $@ net2o-base:$, net2o-base:nestsig
      cell +LOOP ;]
    gen-cmd$ 2drop 0 tmp$ !@ enc-file !




    r> free throw  dispose o>
    $@ >chatid sane-85 .chats/ enc-filename $!
    pk-off  key-list encfile-rest ;

: vault>msg ( -- )
    [: n2o:new-msging >o parent off do-cmd-loop dispose o> ;]

    is write-decrypt ;

: load-msg ( group u -- )  2dup >group
    >chatid sane-85 .chats/ [: type ." .v2o" ;] $tmp
    2dup [IFUNDEF] (file-status) >filename [THEN]
    file-status nip no-file# = IF  2drop EXIT  THEN
    replay-mode on  skip-sig? on
    vault>msg  ['] decrypt-file catch
................................................................................

: last-msg@ ( -- ticks )
    last# >r
    last# $@ ?msg-log last# cell+ $[]# ?dup-IF
	1- last# cell+ $[]@ startdate@
    ELSE  64#0  THEN   r> to last# ;


















:noname ( ticks -- )
    last# 0= ?EXIT
    last# cell+ [: 2dup 2>r startdate@ 64over 64u> IF
	  2r> dup maxstring $10 - u< IF  $, nestsig  ELSE  2drop  THEN
      ELSE  rdrop rdrop   THEN ;] $[]map 64drop ; is msg:getlast
:noname ( -- )
    last-msg@ lit, msg-last ; is msg:last?
:noname ( ticks -- )
    ." last message at: " .ticks forth:cr ; is msg:last



























: group, ( addr u -- )
    $, msg-group ;
: <msg ( -- )
    \G start a msg block
    msg-group$ $@ group, msg sign[ msg-start ;
: msg> ( -- )







|
<
<



|
>
>
>
>




|
|
>
|







 







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









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







53
54
55
56
57
58
59
60


61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
...
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
    THEN ;

: >chatid ( group u -- id u )  defaultkey sec@ keyed-hash#128 ;

: msg-log@ ( last# -- addr u )
    [: cell+ $@ save-mem ;] msglog-sema c-section ;

: serialize-log ( addr u -- addr )


    [: bounds ?DO
	  I $@ net2o-base:$, net2o-base:nestsig
      cell +LOOP ;]
    gen-cmd$ 2drop 0 tmp$ !@ ;

: save-msgs ( last -- )
    ?.net2o/chats  n2o:new-msging >o enc-file $off
    dup msg-log@ over >r  serialize-log enc-file !
    r> free throw  dispose o>
    $@ >chatid sane-85 .chats/ enc-filename $!
    pk-off  key-list encfile-rest ;

: msg-eval ( addr u -- )
    n2o:new-msging >o parent off do-cmd-loop dispose o> ;
: vault>msg ( -- )
    ['] msg-eval is write-decrypt ;

: load-msg ( group u -- )  2dup >group
    >chatid sane-85 .chats/ [: type ." .v2o" ;] $tmp
    2dup [IFUNDEF] (file-status) >filename [THEN]
    file-status nip no-file# = IF  2drop EXIT  THEN
    replay-mode on  skip-sig? on
    vault>msg  ['] decrypt-file catch
................................................................................

: last-msg@ ( -- ticks )
    last# >r
    last# $@ ?msg-log last# cell+ $[]# ?dup-IF
	1- last# cell+ $[]@ startdate@
    ELSE  64#0  THEN   r> to last# ;

\ 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 -- )
    state-addr >o  msgfs-class# fs-class!  fs-create o> ;
: n2o:copy-msg ( group u -- )
    [: last-msg@ 64#-1 64- ticks { 64^ start 64^ end }
      start 1 64s type  end 1 64s type  type ;] $tmp
    [: msgfs-class# ulit, file-type 2dup $, r/o ulit, open-tracked-file
      file-reg# @ save-to-msg ;] n2o>file
    1 file-count +! ;

:noname ( ticks -- )
    last# 0= ?EXIT
    last# cell+ [: 2dup 2>r startdate@ 64over 64u> IF
	  2r> dup maxstring $10 - u< IF  $, nestsig  ELSE  2drop  THEN
      ELSE  rdrop rdrop   THEN ;] $[]map 64drop ; is msg:getlast
:noname ( -- )
    last-msg@ lit, msg-last ; is msg:last?
:noname ( ticks -- )
    ." last message at: " .ticks forth:cr ; is msg:last

:noname ( -- 64len )
    \ poll serializes the 
    fs-outbuf $off
    fs-path $@ 2 64s /string ?msg-log
    last# msg-log@ over >r
    fs-path $@ drop le-64@ last# cell+ $search[]date \ start index
    fs-path $@ drop 64'+ le-64@ last# cell+ $search[]date over - >r
    cells safe/string r> cells umin
    serialize-log  fs-outbuf !
    r> free throw
    fs-inbuf $@len u>64 ; msgfs-class is fs-poll
:noname ( addr u mode -- )  fs-close
    \G addr u is starttick endtick name concatenated together
    drop fs-path $!
    fs-poll fs-size!
; dup msgfs-class is fs-open  msgfs-class is fs-create
:noname ( -- )
    fs-path $@ 2 64s /string >group
    fs-inbuf $@ dup IF  msg-eval  ELSE  2drop  THEN  fs-inbuf $off
; msgfs-class is fs-close
:noname ( perm -- )
    perm%msg and 0= !!msg-perm!!
; msgfs-class to fs-perm?

\ message composer

: group, ( addr u -- )
    $, msg-group ;
: <msg ( -- )
    \G start a msg block
    msg-group$ $@ group, msg sign[ msg-start ;
: msg> ( -- )

Changes to net2o-tools.fs.

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
553
554
555

\ list sorted by sig date

: $ins[]date ( addr u $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 <  WHILE  2dup + 2/ { left right $# }
	    2dup startdate@ $# $a $[]@ startdate@ 64- 64dup 64-0= IF
		64drop 2drop \ don't overwrite if already exists!
		-1 EXIT  THEN
	    64-0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
    0 { w^ ins$0 } ins$0 cell $a r@ cells $ins r@ $a $[]!  r> ;
: $del[]date ( addr u $array -- )
    \G delete O(log(n)) from pre-sorted array
    { $a } 0 $a $[]#
    BEGIN  2dup <  WHILE  2dup + 2/ { left right $# }
	    2dup startdate@ $# $a $[]@ startdate@ 64- 64dup 64-0= IF
		64drop $# $a $[] $off
		$a $# cells cell $del
		2drop EXIT  THEN
	    64-0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT 2drop 2drop ; \ not found










\ filter entries out of a string array

: $[]filter { addr xt -- }
    \G execute @var{xt} for all elements of the string array @var{addr}.
    \G xt is @var{( addr u -- flag )}, getting one string at a time,
    \G if flag is false, delete the corresponding string.







|









|






>
>
>
>
>
>
>
>
>







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
553
554
555
556
557
558
559
560
561
562
563
564

\ list sorted by sig date

: $ins[]date ( addr u $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 $# }
	    2dup startdate@ $# $a $[]@ startdate@ 64- 64dup 64-0= IF
		64drop 2drop \ don't overwrite if already exists!
		-1 EXIT  THEN
	    64-0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r
    0 { w^ ins$0 } ins$0 cell $a r@ cells $ins r@ $a $[]!  r> ;
: $del[]date ( addr u $array -- )
    \G delete O(log(n)) from pre-sorted array
    { $a } 0 $a $[]#
    BEGIN  2dup u<  WHILE  2dup + 2/ { left right $# }
	    2dup startdate@ $# $a $[]@ startdate@ 64- 64dup 64-0= IF
		64drop $# $a $[] $off
		$a $# cells cell $del
		2drop EXIT  THEN
	    64-0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT 2drop 2drop ; \ not found
: $search[]date ( ticks $array -- pos )
    \G search O(log(n)) in pre-sorted array
    \G @var{pos} is the location of the item >= the requested date
    { $a } 0 $a $[]#
    BEGIN  2dup u<  WHILE  2dup + 2/ { left right $# }
	    64dup $# $a $[]@ startdate@ 64- 64dup 64-0= IF
		64drop 64drop $# EXIT  THEN
	    64-0< IF  left $#  ELSE  $# 1+ right  THEN
    REPEAT  drop >r 64drop r> dup $a $[]# = - ;

\ filter entries out of a string array

: $[]filter { addr xt -- }
    \G execute @var{xt} for all elements of the string array @var{addr}.
    \G xt is @var{( addr u -- flag )}, getting one string at a time,
    \G if flag is false, delete the corresponding string.