perf(app): version-keyed caches for visible crops, media index, album counts (P2)
ober
e9924aad7bd682c699a0fd57cc63dd31bc856628
--- a/src/app.ss +++ b/src/app.ss @@ -11,6 +11,7 @@ string-blank? string-prefix? string-contains? string-split-char string-join percent-encode-path percent-decode normalize-answer safe-relative-path? media-mime) + (imagesite cache) (imagesite catalog) (imagesite annotations) (imagesite db) @@ -48,11 +49,18 @@ (def (current-hidden-media-state) (vector-ref app-state 1)) (def (current-unlisted-media-state) (vector-ref app-state 2)) +(def catalog-version 0) + (def (swap-app-state! catalog hidden unlisted) (mutex-lock! state-lock) (set! app-state (vector catalog hidden unlisted)) + (set! catalog-version (+ catalog-version 1)) (mutex-unlock! state-lock)) +(def *visible-media-index-cache* (make-version-cache)) +(def *visible-crops-cache* (make-version-cache)) +(def *album-visible-counts-cache* (make-version-cache)) + (def (read-optional-text path) (if (string-blank? path) "" @@ -253,7 +261,8 @@ (def (visible-media-list media admin?) (if admin? media - (filter (lambda (item) (visible-media? #f item)) media))) + (let ((index (visible-media-index #f))) + (filter (lambda (item) (hash-key? index (h item "rel_path" ""))) media)))) (def (take-limit xs limit) (let loop ((rest xs) (n limit) (out '())) @@ -436,7 +445,7 @@ (object (list (cons "albums" (length (app-list-albums/visible #f))) - (cons "media" (length (visible-media-list (app-all-media) #f))) + (cons "media" (hash-length (visible-media-index #f))) (cons "missing" (h (app-counts) "missing" 0)) (cons "tags" (h (app-counts) "tags" 0)))))) @@ -457,17 +466,37 @@ (or (string-blank? path) (> count 0))) +(def (album-visible-counts admin?) + (if admin? + (let ((counts (make-hash-table))) + (for-each + (lambda (album) + (hash-put! counts (h album "path" "") (h album "media_count" 0))) + (app-list-albums)) + counts) + (version-cache-ref + *album-visible-counts-cache* + catalog-version + (lambda () + (let ((counts (make-hash-table))) + (hash-for-each + (lambda (rel-path media) + (let ((album-path (h media "album_path" ""))) + (hash-put! counts album-path (+ 1 (h counts album-path 0))))) + (visible-media-index #f)) + counts))))) + (def (app-list-albums/visible admin?) - (let loop ((albums (app-list-albums)) (out '())) - (if (null? albums) - (reverse out) - (let* ((album (car albums)) - (path (h album "path" "")) - (media (app-media-by-album/visible path admin?)) - (count (length media))) - (if (display-album? path count) - (loop (cdr albums) (cons (album-with-media-count album count) out)) - (loop (cdr albums) out)))))) + (let ((counts (album-visible-counts admin?))) + (let loop ((albums (app-list-albums)) (out '())) + (if (null? albums) + (reverse out) + (let* ((album (car albums)) + (path (h album "path" "")) + (count (h counts path 0))) + (if (display-album? path count) + (loop (cdr albums) (cons (album-with-media-count album count) out)) + (loop (cdr albums) out))))))) (def (app-album-by-path path) (if use-fs-catalog? @@ -540,13 +569,24 @@ (media-tags db id))) (def (visible-media-index admin?) - (let ((index (make-hash-table))) - (for-each - (lambda (media) - (when (visible-media? admin? media) - (hash-put! index (h media "rel_path" "") media))) - (app-all-media)) - index)) + (if admin? + (let ((index (make-hash-table))) + (for-each + (lambda (media) + (hash-put! index (h media "rel_path" "") media)) + (app-all-media)) + index) + (version-cache-ref + *visible-media-index-cache* + catalog-version + (lambda () + (let ((index (make-hash-table))) + (for-each + (lambda (media) + (when (visible-media? #f media) + (hash-put! index (h media "rel_path" "") media))) + (app-all-media)) + index))))) (def (cluster-media-items/indexed cluster media-index) (let loop ((paths (face-cluster-media-rel-paths cluster)) (out '())) @@ -634,17 +674,26 @@ (def (app-person-cluster cluster-id) (app-person-cluster/visible cluster-id #t)) +(def (visible-crop-set) + (version-cache-ref + *visible-crops-cache* + catalog-version + (lambda () + (let ((crops (make-hash-table))) + (for-each + (lambda (cluster) + (for-each + (lambda (face) + (let ((crop (h face "crop" ""))) + (unless (string-blank? crop) + (hash-put! crops crop #t)))) + (h cluster "faces" '()))) + (app-people-clusters/visible #f)) + crops)))) + (def (visible-face-crop? rel admin?) (or admin? - (let loop-clusters ((clusters (app-people-clusters/visible #f))) - (cond - ((null? clusters) #f) - (else - (let loop-faces ((faces (h (car clusters) "faces" '()))) - (cond - ((null? faces) (loop-clusters (cdr clusters))) - ((string=? (h (car faces) "crop" "") rel) #t) - (else (loop-faces (cdr faces)))))))))) + (hash-key? (visible-crop-set) rel))) (def (save-person-name! cluster-id name) (save-person-label! (config-face-labels-path config) cluster-id name)) new file mode 100644 --- /dev/null +++ b/src/imagesite/cache.ss @@ -0,0 +1,18 @@ +(import (jerboa prelude)) + +(export make-version-cache version-cache-ref version-cache-rebuild-count) + +(def (make-version-cache) + (vector -1 #f 0)) + +(def (version-cache-ref cache current-version compute) + (if (= (vector-ref cache 0) current-version) + (vector-ref cache 1) + (let ((value (compute))) + (vector-set! cache 0 current-version) + (vector-set! cache 1 value) + (vector-set! cache 2 (+ (vector-ref cache 2) 1)) + value))) + +(def (version-cache-rebuild-count cache) + (vector-ref cache 2)) new file mode 100644 --- /dev/null +++ b/tests/imagesite/cache-test.ss @@ -0,0 +1,55 @@ +(import (jerboa prelude) + (imagesite cache)) + +(export run-cache-tests) + +(def pass-count 0) +(def fail-count 0) + +(define-syntax chk + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") (write 'expr) + (display " => ") (write result) + (display " expected ") (write exp) + (newline))))])) + +(def (run-cache-tests) + (set! pass-count 0) + (set! fail-count 0) + (let ((cache (make-version-cache)) + (compute-count 0)) + (let ((compute (lambda () (set! compute-count (+ compute-count 1)) 'value-a))) + (chk (version-cache-rebuild-count cache) => 0) + (chk (version-cache-ref cache 0 compute) => 'value-a) + (chk compute-count => 1) + (chk (version-cache-ref cache 0 compute) => 'value-a) + (chk compute-count => 1) + (chk (version-cache-ref cache 0 compute) => 'value-a) + (chk compute-count => 1) + (chk (version-cache-rebuild-count cache) => 1) + (chk (version-cache-ref cache 1 compute) => 'value-a) + (chk compute-count => 2) + (chk (version-cache-ref cache 1 compute) => 'value-a) + (chk compute-count => 2) + (chk (version-cache-rebuild-count cache) => 2)) + (let ((cache2 (make-version-cache)) + (values '(x y z)) + (idx 0)) + (chk (version-cache-ref cache2 10 (lambda () (list-ref values 0))) => 'x) + (chk (version-cache-ref cache2 11 (lambda () (list-ref values 1))) => 'y) + (chk (version-cache-ref cache2 12 (lambda () (list-ref values 2))) => 'z) + (chk (version-cache-ref cache2 12 (lambda () 'unused)) => 'z) + (chk (version-cache-rebuild-count cache2) => 3)) + (display "cache tests: ") + (display pass-count) + (display " passed, ") + (display fail-count) + (display " failed") + (newline) + (= fail-count 0))) --- a/tests/test-runner.ss +++ b/tests/test-runner.ss @@ -2,6 +2,7 @@ (imagesite util-test) (imagesite annotations-test) (imagesite catalog-test) + (imagesite cache-test) (imagesite people-test) (imagesite media-test) (imagesite db-test) @@ -23,6 +24,7 @@ (run "util" run-util-tests) (run "annotations" run-annotations-tests) (run "catalog" run-catalog-tests) +(run "cache" run-cache-tests) (run "people" run-people-tests) (run "media" run-media-tests) (run "db" run-db-tests)