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: |
e500619da6b43d8f4aad7fb3b7aa615e |
| 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
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
|