Check-in [096c09b945]
Not logged in

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: 096c09b945034089c8c804563585ceffad153ef8
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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