Commit 461cd699 authored by Bernd Paysan's avatar Bernd Paysan

Better async fetch of thumbnails

parent 8a05b8d8
......@@ -952,8 +952,11 @@ previous
: 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 enchash>filename file-status nip no-file# = IF
2dup need-hashed? IF
dvcs( ." need: " 2dup 85type cr )
sync-file-list[] $ins[] drop
ELSE dvcs( ." don't need: " 2dup 85type cr ) 2drop THEN ;
......
......@@ -1039,32 +1039,28 @@ Variable emojis$ "👍👎🤣😍😘😛🤔😭😡😱🔃" emojis$ $! \
Hash: thumbs#
: thumb-frame ( addr u -- rect )
keysize safe/string key|
2dup thumbs# #@ nip 0= IF
key| 2dup thumbs# #@ nip 0= IF
2dup read-avatar 2swap thumbs# #!
ELSE 2drop THEN last# cell+ $@ drop ;
event: :>update-thumb { d: hash object -- }
: 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
: ?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
<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> ;
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[" 2dup 85type ']' emit
;] $tmp }}text >r
<event ['] noop elit, msg:id$ e$, e$,
:>fetch-img ?query-task event> r> endof
msg:image# of [: ." img[" 85type ']' emit
;] $tmp }}text endof
msg:thumbnail# of ?thumb endof
msg:patch# of [: ." patch[" 85type ']' emit
;] $tmp }}text endof
......
......@@ -35,7 +35,7 @@ uvalue last#
: #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 ;
rdrop false ;
$180 cells Constant table-size#
......@@ -61,6 +61,9 @@ warnings !
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
......
......@@ -477,28 +477,72 @@ scope: logstyles
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 }
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
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 ;
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
<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: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
......@@ -1638,16 +1682,14 @@ forward hash-in
[: 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
?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
[: 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 ;]
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 ;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment