Check-in [e500619da6]
Not logged in

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

Overview
Comment:Better async fetch of thumbnails
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e500619da6b43d8f4aad7fb3b7aa615ea7544ca7
User & Date: bernd 2019-12-01 23:02:19
Context
2019-12-02
20:27
Chat thumbnail handling considderably improved check-in: 096c09b945 user: bernd tags: trunk
2019-12-01
23:02
Better async fetch of thumbnails check-in: e500619da6 user: bernd tags: trunk
2019-11-30
22:46
Elaborate social network stuff check-in: b0f6281680 user: bernd tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to dvcs.fs.

948
949
950
951
952
953
954



955
956

957
958
959
960
961
962
963

: dvcs-connects? ( -- flag )
    chat-keys ['] dvcs-connect-key $[]map dvcs-request# @ 0> ;

: wait-dvcs-request ( -- )
    BEGIN  dvcs-request# @  WHILE  stop  REPEAT ;




: +needed ( addr u -- )
    2dup enchash>filename file-status nip no-file# = IF

	dvcs( ." need: " 2dup 85type cr )
	sync-file-list[] $ins[] drop
    ELSE  dvcs( ." don't need: " 2dup 85type cr ) 2drop  THEN ;

: #needed ( hash -- )
    cell+ $@ key| +needed ;
: dvcs-needed-files ( -- )







>
>
>

<
>







948
949
950
951
952
953
954
955
956
957
958

959
960
961
962
963
964
965
966

: dvcs-connects? ( -- flag )
    chat-keys ['] dvcs-connect-key $[]map dvcs-request# @ 0> ;

: wait-dvcs-request ( -- )
    BEGIN  dvcs-request# @  WHILE  stop  REPEAT ;

: need-hashed? ( addr u -- flag )
    enchash>filename 2dup type cr file-status nip no-file# = ;

: +needed ( addr u -- )

    2dup need-hashed? IF
	dvcs( ." need: " 2dup 85type cr )
	sync-file-list[] $ins[] drop
    ELSE  dvcs( ." don't need: " 2dup 85type cr ) 2drop  THEN ;

: #needed ( hash -- )
    cell+ $@ key| +needed ;
: dvcs-needed-files ( -- )

Changes to gui.fs.

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
	    THEN
	LOOP
    THEN ; wmsg-class is msg:otrify

Hash: thumbs#

: thumb-frame ( addr u -- rect )
    keysize safe/string key|
    2dup thumbs# #@ nip 0= IF
	2dup read-avatar 2swap thumbs# #!
    ELSE  2drop  THEN  last# cell+ $@ drop ;

event: :>update-thumb { d: hash object -- }
    hash thumb-frame object .childs[] $@ drop @ >o to frame#
    frame# i.w frame# i.h tile-glue .wh-glue!  o>
    [: +sync +resize ;] msgs-box vp-needed +sync +resize ;

: ?thumb ( addr u -- o )
    2dup ['] thumb-frame catch 0= IF
	>r 2drop r@ i.w r@ i.h glue*thumb r> }}thumb
	EXIT  THEN
    128 128 glue*thumb dummy-thumb }}thumb >r
    <event r@ up@ [{: hash u1 object task :}h
	<event hash elit, u1 elit, object elit, :>update-thumb task event> ;] elit, msg:id$ e$, e$,
    :>fetch-thumb ?query-task event> r> ;

:noname ( addr u type -- )
    obj-red
    case 0 >r
	msg:image#     of  [: ." img["      2dup 85type ']' emit
	    ;] $tmp }}text >r
	    <event ['] noop elit, msg:id$ e$, e$,
	    :>fetch-img ?query-task event> r>        endof
	msg:thumbnail# of  ?thumb                    endof
	msg:patch#     of  [: ." patch["    85type ']' emit
	    ;] $tmp }}text  endof
	msg:snapshot#  of  [: ." snapshot[" 85type ']' emit
	    ;] $tmp }}text  endof
	msg:message#   of  [: ." message["  85type ']' emit
	    ;] $tmp }}text  endof







<
|



|




|
|
|


|
|
<




|
|
<
<







1035
1036
1037
1038
1039
1040
1041

1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057

1058
1059
1060
1061
1062
1063


1064
1065
1066
1067
1068
1069
1070
	    THEN
	LOOP
    THEN ; wmsg-class is msg:otrify

Hash: thumbs#

: thumb-frame ( addr u -- rect )

    key| 2dup thumbs# #@ nip 0= IF
	2dup read-avatar 2swap thumbs# #!
    ELSE  2drop  THEN  last# cell+ $@ drop ;

: update-thumb { d: hash object -- }
    hash thumb-frame object .childs[] $@ drop @ >o to frame#
    frame# i.w frame# i.h tile-glue .wh-glue!  o>
    [: +sync +resize ;] msgs-box vp-needed +sync +resize ;

: ?thumb { d: hash -- o }
    hash ['] thumb-frame catch 0= IF
	>r r@ i.w r@ i.h glue*thumb r> }}thumb
	EXIT  THEN
    128 128 glue*thumb dummy-thumb }}thumb >r
    r@ [n:h update-thumb ;] { w^ xt } xt cell hash key| fetch-finish# #!
    hash key| ?fetch r> ;


:noname ( addr u type -- )
    obj-red
    case 0 >r
	msg:image#     of  [: ." img["      85type ']' emit
	    ;] $tmp }}text                           endof


	msg:thumbnail# of  ?thumb                    endof
	msg:patch#     of  [: ." patch["    85type ']' emit
	    ;] $tmp }}text  endof
	msg:snapshot#  of  [: ." snapshot[" 85type ']' emit
	    ;] $tmp }}text  endof
	msg:message#   of  [: ." message["  85type ']' emit
	    ;] $tmp }}text  endof

Changes to hash-table.fs.

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
..
57
58
59
60
61
62
63



64
65
66
67
68
69
70
    rdrop false ;    

: bucket-off ( bucket -- ) dup $off cell+ $off ;

: #free? ( addrkey u bucket -- true / addrkey u false )
    >r r@ @ 0= IF  rdrop false  EXIT  THEN
    2dup r@ $@ str=  IF  2drop r> bucket-off true  EXIT  THEN
    rdrop false ;    

$180 cells Constant table-size#

: hash@ ( bucket -- addr )  >r
    r@ @ 0= IF  table-size# allocate throw dup table-size# erase dup r> !
    ELSE  r> @  THEN ;

................................................................................
: #@ ( addrkey u hash -- addrval u / 0 0 ) { hash }
    2dup string-hash  hash$ bounds ?DO
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
	+ #@? IF  UNLOOP  EXIT  THEN
	I c@ $80 or $80 + cells hash @ + to hash
    LOOP  2drop #0. ;




: #free ( addrkey u hash -- )  { hash }
    2dup string-hash  hash$ bounds ?DO
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
	+ #free? IF  UNLOOP  EXIT  THEN
	I c@ $80 or $80 + cells hash @ + to hash
    LOOP  2drop ;








|







 







>
>
>







31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
..
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
    rdrop false ;    

: bucket-off ( bucket -- ) dup $off cell+ $off ;

: #free? ( addrkey u bucket -- true / addrkey u false )
    >r r@ @ 0= IF  rdrop false  EXIT  THEN
    2dup r@ $@ str=  IF  2drop r> bucket-off true  EXIT  THEN
    rdrop false ;

$180 cells Constant table-size#

: hash@ ( bucket -- addr )  >r
    r@ @ 0= IF  table-size# allocate throw dup table-size# erase dup r> !
    ELSE  r> @  THEN ;

................................................................................
: #@ ( addrkey u hash -- addrval u / 0 0 ) { hash }
    2dup string-hash  hash$ bounds ?DO
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
	+ #@? IF  UNLOOP  EXIT  THEN
	I c@ $80 or $80 + cells hash @ + to hash
    LOOP  2drop #0. ;

: #+! ( addr1 u1 addr2 u2 -- )
    2dup #@ d0= IF  #!  ELSE  2drop last# cell+ $+!  THEN ;

: #free ( addrkey u hash -- )  { hash }
    2dup string-hash  hash$ bounds ?DO
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
	+ #free? IF  UNLOOP  EXIT  THEN
	I c@ $80 or $80 + cells hash @ + to hash
    LOOP  2drop ;

Changes to msg.fs.

473
474
475
476
477
478
479
480
481
482
483

484













485
486


487

488
489






490
491

























492
493




494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
....
1634
1635
1636
1637
1638
1639
1640
1641


1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
	dup 1 and IF  I xc@ xemit  THEN  2/
    I I' over - x-size  +LOOP  drop ;
:noname { 64^ perm d: pk -- }
    perm [ 1 64s ]L pk msg-group-o .msg:perms# #!
    pk .key-id ." : " perm 64@ 64>n .perms space
; msg-class is msg:perms

event: :>fetch-img { xt: action d: pk d: hash }
    pk $8 $E pk-connect? IF  +resend +flow-control
	net2o-code expect+slurp $10 blocksize! $A blockalign!
	hash key| net2o:copy# end-code| net2o:close-all disconnect-me

	action













    ELSE  2drop  THEN ;
event: :>fetch-thumb { xt: action d: pk d: hash }


    pk $8 $E pk-connect? IF  +resend +flow-control

	net2o-code expect+slurp $10 blocksize! $A blockalign!
	hash keysize safe/string key| net2o:copy#






	hash key| net2o:copy# end-code| net2o:close-all disconnect-me
	hash keysize 2* safe/string drop c@ action

























    ELSE  2drop  THEN ;





:noname ( addr u type -- )
    space <warn> case
	msg:image#     of  ." img["      2dup 85type
	    <event ['] noop elit, msg:id$ e$, e$,
	    :>fetch-img ?query-task event>       endof
	msg:thumbnail# of  ." thumb["    85type ( 2dup 85type
	    <event ['] drop elit, msg:id$ e$, e$,
	    :>fetch-thumb ?query-task event> )   endof
	msg:patch#     of  ." patch["    85type  endof
	msg:snapshot#  of  ." snapshot[" 85type  endof
	msg:message#   of  ." message["  85type  endof
	drop
	2dup keysize /string
	2dup printable? IF  '[' emit  type '@' emit
	ELSE  ." #["  85type ." /@"  THEN
................................................................................
    dup 4 - 0 max safe/string ".jpg" str= ;
: img-rec ( addr u -- .. token )
    2dup "img:" string-prefix? IF
	over ?flush-text
	[:  2dup + >r
	    4 /string save-mem over >r 2dup jpeg? IF
		2dup >thumbnail
		?dup-IF  over >r hash-in save-mem r> free throw  THEN


	    ELSE  #0.  THEN
	    2swap slurp-file over >r hash-in r> free throw
	    [: forth:type dup IF
		    over >r forth:type img-orient 1- 0 max forth:emit
		    r> free throw
		ELSE  2drop  THEN ;] $tmp r> free throw
	    [: dup >r $, msg:thumbnail# msg:image# r> $20 u> select ulit,
		msg-object ;]
	    r> to last->in ;]
	catch 0= IF  rectype-name  EXIT  THEN  THEN
    2drop rectype-null ;

$Variable msg-recognizer
depth >r
' text-rec ' img-rec ' http-rec ' chain-rec ' tag-rec ' pk-rec
depth r> - msg-recognizer set-stack







|
|
|
<
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
>

>
|
<
>
>
>
>
>
>
|
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

>
>
>
>


|
<
<
|
<
<







 







|
>
>

|
<
<
|
<
<
|
|







473
474
475
476
477
478
479
480
481
482

483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498

499
500
501
502
503

504
505
506
507
508
509
510

511
512
513
514
515
516
517
518
519
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
....
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689


1690


1691
1692
1693
1694
1695
1696
1697
1698
1699
	dup 1 and IF  I xc@ xemit  THEN  2/
    I I' over - x-size  +LOOP  drop ;
:noname { 64^ perm d: pk -- }
    perm [ 1 64s ]L pk msg-group-o .msg:perms# #!
    pk .key-id ." : " perm 64@ 64>n .perms space
; msg-class is msg:perms

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 }
    fetch-finish# #@ IF
	@ >r hash r@ execute r> >addr free throw
	last# bucket-off
    ELSE  drop  THEN ;


: fetch-queue { task d: pk d: hashs -- }
    pk $8 $E pk-connect? IF  +resend +flow-control
	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
		    <event hash e$, :>hash-finished ;]
		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 ;

:noname ( addr u type -- )
    space <warn> case
	msg:image#     of  ." img["      2dup 85type ?fetch  endof


	msg:thumbnail# of  ." thumb["    2dup 85type ?fetch  endof


	msg:patch#     of  ." patch["    85type  endof
	msg:snapshot#  of  ." snapshot[" 85type  endof
	msg:message#   of  ." message["  85type  endof
	drop
	2dup keysize /string
	2dup printable? IF  '[' emit  type '@' emit
	ELSE  ." #["  85type ." /@"  THEN
................................................................................
    dup 4 - 0 max safe/string ".jpg" str= ;
: img-rec ( addr u -- .. token )
    2dup "img:" string-prefix? IF
	over ?flush-text
	[:  2dup + >r
	    4 /string save-mem over >r 2dup jpeg? IF
		2dup >thumbnail
		?dup-IF  over >r hash-in
		    [: forth:type img-orient forth:emit ;] $tmp
		    r> free throw  THEN
	    ELSE  #0.  THEN
	    2swap slurp-file over >r hash-in r> free throw  2swap


	    [:  dup IF  $, msg:thumbnail# ulit, msg-object  ELSE  2drop  THEN


		$, msg:image# ulit, msg-object ;]
	    r> free throw  r> to last->in ;]
	catch 0= IF  rectype-name  EXIT  THEN  THEN
    2drop rectype-null ;

$Variable msg-recognizer
depth >r
' text-rec ' img-rec ' http-rec ' chain-rec ' tag-rec ' pk-rec
depth r> - msg-recognizer set-stack