Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Chat thumbnail handling considderably improved |
|---|---|
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
096c09b945034089c8c804563585ceff |
| User & Date: | bernd 2019-12-02 20:27:46 |
Context
|
2019-12-02
| ||
| 22:24 | Start album viewer check-in: a28a0f2c63 user: bernd tags: trunk | |
| 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 | |
Changes
Changes to dvcs.fs.
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
...
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
|
hash#128 buffer: hash-save
: hash-in ( addr u -- hash u )
2dup >file-hash hash-save hash#128 smove
write-enc-hashed 2drop
hash-save hash#128 ;
: hash-add ( addr u -- )
slurp-file hash-in 2drop ;
: hash-out ( addr u -- )
base85>$ 2dup 2>r read-enc-hashed patch-in$ $@ 2r> hash-85 spit-file ;
\ pull and sync a database
$B $E 2Value dvcs-bufs#
................................................................................
: 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 ;
|
|
|
|
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
...
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
|
hash#128 buffer: hash-save
: hash-in ( addr u -- hash u )
2dup >file-hash hash-save hash#128 smove
write-enc-hashed 2drop
hash-save hash#128 ;
: hash-add ( addr u -- )
slurp-file over >r hash-in 2drop r> free throw ;
: hash-out ( addr u -- )
base85>$ 2dup 2>r read-enc-hashed patch-in$ $@ 2r> hash-85 spit-file ;
\ pull and sync a database
$B $E 2Value dvcs-bufs#
................................................................................
: 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 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 ;
|
Changes to gui.fs.
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
....
1032
1033
1034
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
1075
1076
1077
1078
1079
1080
1081
1082
1083
|
dummy-thumb# @ 0= IF
read-thumb.png thumb.png$ $@ mem>thumb atlas-region
dummy-thumb# $!
THEN dummy-thumb# $@ drop ;
: avatar-thumb ( avatar -- )
glue*avatar swap }}thumb >r {{ r> }}v 40%b ;
: avatar-frame ( addr u -- frame# )
2dup avatar# #@ nip 0= IF
2dup read-avatar 2swap avatar# #!
ELSE 2drop THEN last# cell+ $@ drop ;
: show-avatar ( addr u -- o / 0 )
[: avatar-frame avatar-thumb ;] catch IF 2drop 0 THEN ;
: re-avatar ( last# -- )
>r r@ $@ read-avatar r> cell+ $@ smove ;
................................................................................
ELSE
I [: ." [OTRifignore] #" u. forth:cr ;] do-debug
2drop
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
msg:posting# of ." posting"
rdrop 2dup [d:h open-posting ;] >r
['] .posting $tmp }}text
endof
endcase r> ?dup-IF 0 click[] THEN
"object" name! msg-box .child+
text-color!
; wmsg-class is msg:object
in net2o : new-wmsg ( o:connection -- o )
o wmsg-class new >o parent! msg-table @ token-table ! o o> ;
' net2o:new-wmsg is net2o:new-msg
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
|
|
>
>
>
>
>
>
|
|
|
|
|
|
|
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
....
1032
1033
1034
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
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
|
dummy-thumb# @ 0= IF
read-thumb.png thumb.png$ $@ mem>thumb atlas-region
dummy-thumb# $!
THEN dummy-thumb# $@ drop ;
: avatar-thumb ( avatar -- )
glue*avatar swap }}thumb >r {{ r> }}v 40%b ;
: avatar-frame ( addr u -- frame# )
key| 2dup avatar# #@ nip 0= IF
2dup read-avatar 2swap avatar# #!
ELSE 2drop THEN last# cell+ $@ drop ;
: show-avatar ( addr u -- o / 0 )
[: avatar-frame avatar-thumb ;] catch IF 2drop 0 THEN ;
: re-avatar ( last# -- )
>r r@ $@ read-avatar r> cell+ $@ smove ;
................................................................................
ELSE
I [: ." [OTRifignore] #" u. forth:cr ;] do-debug
2drop
THEN
LOOP
THEN ; wmsg-class is msg:otrify
: >rotate ( addr u -- )
keysize safe/string IF c@ to rotate# ELSE drop THEN ;
: >swap ( w h addr u -- w h / h w )
keysize safe/string IF c@ 4 and IF swap THEN ELSE drop THEN ;
: update-thumb { d: hash object -- }
hash avatar-frame object >o to frame# hash >rotate
frame# i.w 2* frame# i.h 2* tile-glue hash >swap .wh-glue! o>
[: +sync +resize ;] msgs-box .vp-needed +sync +resize ;
: 40%bv ( o -- o ) >o current-font-size% 40% f* fdup to border
fnegate f2/ to borderv o o> ;
: ?thumb { d: hash -- o }
hash ['] avatar-frame catch 0= IF
>r r@ i.w 2* r@ i.h 2* hash >swap
glue*thumb r> }}thumb >r hash r@ .>rotate
ELSE
128 128 glue*thumb dummy-thumb }}thumb >r
r@ [n:h update-thumb ;] { w^ xt } xt cell hash key| fetch-finish# #!
hash key| ?fetch
THEN {{ glue*ll }}glue r> }}v 40%bv box[] ;
:noname ( addr u type -- )
obj-red
case 0 >r
msg:image# of
msg-box .childs[] $[]# ?dup-IF
rdrop 1- msg-box .childs[] $[] @
dup .name$ "thumbnail" str= IF
[: ." display image: " addr data $@ 85type cr ;]
2swap $make click[] drop EXIT THEN drop THEN
[: ." img[" 85type ']' emit ;] $tmp }}text "image" name!
endof
msg:thumbnail# of ?thumb "thumbnail" name! endof
msg:patch# of [: ." patch[" 85type ']' emit
;] $tmp }}text "patch" name! endof
msg:snapshot# of [: ." snapshot[" 85type ']' emit
;] $tmp }}text "snapshot" name! endof
msg:message# of [: ." message[" 85type ']' emit
;] $tmp }}text "message" name! endof
msg:posting# of ." posting"
rdrop 2dup [d:h open-posting ;] >r
['] .posting $tmp }}text "posting" name!
endof
endcase r> ?dup-IF 0 click[] THEN
msg-box .child+
text-color!
; wmsg-class is msg:object
in net2o : new-wmsg ( o:connection -- o )
o wmsg-class new >o parent! msg-table @ token-table ! o o> ;
' net2o:new-wmsg is net2o:new-msg
|
Changes to msg.fs.
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 ... 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 ... 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 .... 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 |
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
................................................................................
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
................................................................................
+zero16 nest$
0 msg-group-o .msg:keys[] $[]@ encrypt$
['] .encsign ']nestsig ;
\ nest-sig for msg/msging classes
' message msging-class is start-req
:noname check-date >r 2dup r> ; msging-class is nest-sig
' message msg-class is start-req
:noname 2dup msg-dec?-sig? ; msg-class is nest-sig
' context-table is gen-table
also }scope
................................................................................
: 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
|
| | | > | | |
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 ... 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 ... 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 .... 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 |
last# cell+ $@len 0= IF
last# $free last# cell+ $free
THEN
THEN
THEN hashs drop free throw
-1 queued# +! ;
event: :>hash-finished { d: hash }
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 task event> ;]
lastfile@ >o to file-xt o>
keysize +LOOP
end-code| net2o:close-all
keysize $10 * +LOOP
disconnect-me
ELSE
hashs drop 0 to hashs
................................................................................
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 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
................................................................................
+zero16 nest$
0 msg-group-o .msg:keys[] $[]@ encrypt$
['] .encsign ']nestsig ;
\ nest-sig for msg/msging classes
' message msging-class is start-req
:noname quicksig( check-date )else( pk-sig? )
>r 2dup r> ; msging-class is nest-sig
' message msg-class is start-req
:noname 2dup msg-dec?-sig? ; msg-class is nest-sig
' context-table is gen-table
also }scope
................................................................................
: 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 1- 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
|