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.327 |
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 | : dvcs-connects? ( -- flag ) chat-keys ['] dvcs-connect-key $[]map dvcs-request# @ 0> ; : wait-dvcs-request ( -- ) BEGIN dvcs-request# @ WHILE stop REPEAT ; : +needed ( addr u -- ) | > > > | | 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 | THEN LOOP THEN ; wmsg-class is msg:otrify Hash: thumbs# : thumb-frame ( addr u -- rect ) | < | | | | | < | | | | < < | 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 | 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 | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | 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 ; |
︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 | : #@ ( 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 ; | > > > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | : #@ ( 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 | 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 | > > > | > > > > > > > > > > > > > > > > > > | > > > > > > | > | | > > > > | | > > > > | > > > > > | > > > > > > | | > | | < < | < < | 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 | 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 |
︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 | 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 | | > > | < < < | < | | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 | 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 |
︙ | ︙ |