fix: state race condition, hash-get guards, origin check, key separation
ober
4648af0efc2ee1c3b37a94535a31be880624009f
--- a/src/app.ss +++ b/src/app.ss @@ -25,15 +25,33 @@ (def config (load-config)) (def use-fs-catalog? (config-use-fs-catalog? config)) (def db (if use-fs-catalog? #f (imagesite-open (config-db-path config)))) -(def hidden-media-state (load-hidden-media (config-hidden-media-path config))) -(def unlisted-media-state (load-hidden-media (config-unlisted-media-path config))) +(def state-lock (make-mutex)) -(def (build-catalog-state) +(def (build-catalog-state hidden) (catalog-build/hidden (config-media-root config) - hidden-media-state + hidden (config-annotations-root config))) -(def catalog-state (if use-fs-catalog? (build-catalog-state) #f)) +;; Mutable server state (catalog, hidden-media, unlisted-media) is bundled into +;; a single snapshot vector. Background rebuilds construct a new snapshot and +;; swap the reference atomically under state-lock; request handlers read the +;; snapshot reference, so they always observe a mutually consistent combination +;; rather than a torn mix of old and new state. +(def app-state + (let ((hidden (load-hidden-media (config-hidden-media-path config))) + (unlisted (load-hidden-media (config-unlisted-media-path config)))) + (vector (if use-fs-catalog? (build-catalog-state hidden) #f) + hidden + unlisted))) + +(def (current-catalog-state) (vector-ref app-state 0)) +(def (current-hidden-media-state) (vector-ref app-state 1)) +(def (current-unlisted-media-state) (vector-ref app-state 2)) + +(def (swap-app-state! catalog hidden unlisted) + (mutex-lock! state-lock) + (set! app-state (vector catalog hidden unlisted)) + (mutex-unlock! state-lock)) (def (read-optional-text path) (if (string-blank? path) @@ -200,16 +218,20 @@ (person-tag-job state label count message))))) (def (reload-hidden-media!) - (set! hidden-media-state (load-hidden-media (config-hidden-media-path config))) - hidden-media-state) + (let ((hidden (load-hidden-media (config-hidden-media-path config)))) + (swap-app-state! (current-catalog-state) hidden (current-unlisted-media-state)) + hidden)) (def (reload-unlisted-media!) - (set! unlisted-media-state (load-hidden-media (config-unlisted-media-path config))) - unlisted-media-state) + (let ((unlisted (load-hidden-media (config-unlisted-media-path config)))) + (swap-app-state! (current-catalog-state) (current-hidden-media-state) unlisted) + unlisted)) (def (rebuild-catalog!) (when use-fs-catalog? - (set! catalog-state (build-catalog-state)))) + (swap-app-state! (build-catalog-state (current-hidden-media-state)) + (current-hidden-media-state) + (current-unlisted-media-state)))) (def (refresh-hidden-catalog!) (reload-hidden-media!) @@ -217,13 +239,13 @@ (rebuild-catalog!)) (def (app-hidden-paths) - (hidden-media-paths hidden-media-state)) + (hidden-media-paths (current-hidden-media-state))) (def (app-hidden-count) - (hidden-media-count hidden-media-state)) + (hidden-media-count (current-hidden-media-state))) (def (unlisted-media? media) - (hidden-path? unlisted-media-state (h media "rel_path" ""))) + (hidden-path? (current-unlisted-media-state) (h media "rel_path" ""))) (def (visible-media? admin? media) (or admin? (not (unlisted-media? media)))) @@ -272,6 +294,9 @@ (origin (sinatra-request-header (request) "Origin")) (referer (sinatra-request-header (request) "Referer"))) (and expected + ;; Require at least one of Origin/Referer to be present; a POST that + ;; carries neither cannot be verified as same-origin. + (or origin referer) (or (not origin) (and (header-value-safe? origin) (string-ci=? origin expected))) @@ -322,7 +347,7 @@ (def (app-duplicate-groups limit) (if use-fs-catalog? - (catalog-duplicate-groups catalog-state limit) + (catalog-duplicate-groups (current-catalog-state) limit) '())) (def (matching-duplicate-group basename size) @@ -397,12 +422,12 @@ (def (app-counts) (if use-fs-catalog? - (catalog-counts catalog-state) + (catalog-counts (current-catalog-state)) (counts db))) (def (app-all-media) (if use-fs-catalog? - (catalog-all-media catalog-state) + (catalog-all-media (current-catalog-state)) (recent-media db 100000))) (def (app-counts/visible admin?) @@ -417,12 +442,12 @@ (def (app-latest-sync) (if use-fs-catalog? - (catalog-latest-sync catalog-state) + (catalog-latest-sync (current-catalog-state)) (latest-sync db))) (def (app-list-albums) (if use-fs-catalog? - (catalog-list-albums catalog-state) + (catalog-list-albums (current-catalog-state)) (list-albums db))) (def (app-media-by-album/visible album-path admin?) @@ -446,7 +471,7 @@ (def (app-album-by-path path) (if use-fs-catalog? - (let loop ((albums (catalog-list-albums catalog-state))) + (let loop ((albums (catalog-list-albums (current-catalog-state)))) (cond ((null? albums) #f) ((string=? (h (car albums) "path" "") path) (car albums)) @@ -464,7 +489,7 @@ (def (app-recent-media limit) (if use-fs-catalog? - (catalog-recent-media catalog-state limit) + (catalog-recent-media (current-catalog-state) limit) (recent-media db limit))) (def (app-recent-media/visible limit admin?) @@ -472,22 +497,22 @@ (def (app-media-by-id id) (if use-fs-catalog? - (catalog-media-by-id catalog-state id) + (catalog-media-by-id (current-catalog-state) id) (media-by-id db id))) (def (app-media-by-path rel-path) (if use-fs-catalog? - (catalog-media-by-path catalog-state rel-path) + (catalog-media-by-path (current-catalog-state) rel-path) #f)) (def (app-media-by-album album-path) (if use-fs-catalog? - (catalog-media-by-album catalog-state album-path) + (catalog-media-by-album (current-catalog-state) album-path) (media-by-album db album-path))) (def (app-media-by-kind kind) (if use-fs-catalog? - (catalog-media-by-kind catalog-state kind) + (catalog-media-by-kind (current-catalog-state) kind) (media-by-kind db kind))) (def (app-media-by-kind/visible kind admin?) @@ -495,7 +520,7 @@ (def (app-search-media query limit) (if use-fs-catalog? - (catalog-search-media catalog-state query limit) + (catalog-search-media (current-catalog-state) query limit) (search-media db query limit))) (def (app-search-media/visible query limit admin?) @@ -503,7 +528,7 @@ (def (app-media-by-tag tag limit) (if use-fs-catalog? - (catalog-media-by-tag catalog-state tag limit) + (catalog-media-by-tag (current-catalog-state) tag limit) (media-by-tag db tag limit))) (def (app-media-by-tag/visible tag limit admin?) @@ -511,7 +536,7 @@ (def (app-media-tags id) (if use-fs-catalog? - (catalog-media-tags catalog-state id) + (catalog-media-tags (current-catalog-state) id) (media-tags db id))) (def (visible-media-index admin?) @@ -799,8 +824,8 @@ (begin (reload-hidden-media!) (reload-unlisted-media!) - (set! catalog-state (build-catalog-state)) - (let ((counts (catalog-counts catalog-state))) + (rebuild-catalog!) + (let ((counts (catalog-counts (current-catalog-state)))) (object (list (cons "seen" (h counts "media" 0)) (cons "added" 0) @@ -1231,7 +1256,7 @@ (rel (percent-decode raw-rel)) (valid-rel? (safe-relative-path? rel))) (if (and valid-rel? - (not (hidden-path? hidden-media-state rel)) + (not (hidden-path? (current-hidden-media-state) rel)) (app-media-by-path rel)) (try (send-authorized-media rel) --- a/src/imagesite/config.ss +++ b/src/imagesite/config.ss @@ -1,5 +1,7 @@ (import (only (imagesite util) - getenv/default env-truthy? normalize-answer)) + getenv/default env-truthy? normalize-answer) + (only (std crypto) hmac-sha256) + (only (std text base64) u8vector->base64-string)) (export load-config config-ref config-ref/default config-db-path config-media-root config-metadata-root config-derivative-root @@ -16,6 +18,15 @@ config-unlisted-media-path config-use-fs-catalog?) +;; Derive a purpose-specific access-cookie key from the session secret so the +;; cookie token never reuses the session-secret key material directly. +(def (derive-access-cookie-token session-secret) + (if (string=? session-secret "") + "" + (u8vector->base64-string + (hmac-sha256 (string->utf8 session-secret) + (string->utf8 "jerboa-imagesite.access-cookie-token"))))) + (def (load-config) (let ((config (make-hash-table)) (metadata-root (getenv/default "JERBOA_IMAGESITE_METADATA_ROOT" "var/metadata")) @@ -41,7 +52,8 @@ (hash-put! config "admin-answer" (normalize-answer (getenv/default "JERBOA_IMAGESITE_ADMIN_ANSWER" ""))) (hash-put! config "access-cookie-token" (getenv/default "JERBOA_IMAGESITE_ACCESS_COOKIE_TOKEN" - (getenv/default "JERBOA_IMAGESITE_SESSION_SECRET" ""))) + (derive-access-cookie-token + (getenv/default "JERBOA_IMAGESITE_SESSION_SECRET" "")))) (hash-put! config "admin-token" (getenv/default "JERBOA_IMAGESITE_ADMIN_TOKEN" "")) (hash-put! config "direct-media" (env-truthy? "JERBOA_IMAGESITE_DIRECT_MEDIA" --- a/src/imagesite/db.ss +++ b/src/imagesite/db.ss @@ -271,25 +271,32 @@ (and value (not (equal? value #f)))) (def (update-media-metadata! db media-id meta) - (let ((title (hash-get meta "title")) - (caption (hash-get meta "caption")) - (taken-at (hash-get meta "taken_at")) - (width (maybe-int (hash-get meta "width"))) - (height (maybe-int (hash-get meta "height"))) - (favorite (if (json-bool? (hash-get meta "favorite")) 1 0))) - (when (or title caption taken-at width height (hash-get meta "favorite")) + (let* ((has-title (hash-key? meta "title")) + (has-caption (hash-key? meta "caption")) + (has-taken-at (hash-key? meta "taken_at")) + (has-width (hash-key? meta "width")) + (has-height (hash-key? meta "height")) + (has-favorite (hash-key? meta "favorite")) + (title (and has-title (hash-get meta "title"))) + (caption (and has-caption (hash-get meta "caption"))) + (taken-at (and has-taken-at (hash-get meta "taken_at"))) + (width (and has-width (maybe-int (hash-get meta "width")))) + (height (and has-height (maybe-int (hash-get meta "height")))) + (favorite (and has-favorite + (if (json-bool? (hash-get meta "favorite")) 1 0)))) + (when (or has-title has-caption has-taken-at has-width has-height has-favorite) (sqlite-eval db "UPDATE media SET title = COALESCE(?, title), caption = COALESCE(?, caption), taken_at = COALESCE(?, taken_at), width = COALESCE(?, width), height = COALESCE(?, height), - favorite = ?, + favorite = COALESCE(?, favorite), updated_at = CURRENT_TIMESTAMP WHERE id = ?" (sql-param title) (sql-param caption) (sql-param taken-at) - (sql-param width) (sql-param height) favorite media-id))) - (let ((tags (hash-get meta "tags"))) + (sql-param width) (sql-param height) (sql-param favorite) media-id))) + (let ((tags (and (hash-key? meta "tags") (hash-get meta "tags")))) (when (list? tags) (set-media-tags! db media-id tags)))) --- a/src/imagesite/views.ss +++ b/src/imagesite/views.ss @@ -16,7 +16,9 @@ "\">")) (def (h row key default) - (or (hash-get row key) default)) + (if (and row (hash-key? row key)) + (hash-get row key) + default)) (def (nonblank-string-field row key) (let ((value (hash-get row key)))