From 0759cd10c2d9eaa80beee8371be0278ab72c7196 Mon Sep 17 00:00:00 2001 From: saturn Date: Tue, 14 Mar 2023 01:57:36 -0500 Subject: [PATCH] Add support for last-modified HTTP header. --- lw2.lisp | 14 ++++-- src/backend.lisp | 103 +++++++++++++++++++++++++++------------------ src/background-loader.lisp | 4 +- src/utils.lisp | 5 ++- 4 files changed, 78 insertions(+), 48 deletions(-) diff --git a/lw2.lisp b/lw2.lisp index a8b54c4b..34deb2ab 100644 --- a/lw2.lisp +++ b/lw2.lisp @@ -1044,6 +1044,11 @@ signaled condition to *HTML-OUTPUT*." :extra-class html-class)) (or sort-string (user-pref pref))))) +(defun handle-last-modified (last-modified) + (when last-modified + (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date last-modified)) + (hunchentoot:handle-if-modified-since last-modified))) + (define-component view-index () (:http-args ((view :member '(:all :new :frontpage :featured :alignment-forum :questions :nominations :reviews :events) :default :frontpage) before after @@ -1053,8 +1058,9 @@ signaled condition to *HTML-OUTPUT*." &without-csrf-check)) (when (eq view :new) (redirect (replace-query-params (hunchentoot:request-uri*) "view" "all" "all" nil) :type :permanent) (return)) (component-value-bind ((sort-string sort-widget)) - (multiple-value-bind (posts total) + (multiple-value-bind (posts total last-modified) (get-posts-index :view (string-downcase view) :before before :after after :offset offset :limit (1+ limit) :sort sort-string :karma-threshold karma-threshold) + (handle-last-modified last-modified) (let ((page-title (format nil "~@(~A posts~)" view))) (renderer () (view-items-index (firstn posts limit) @@ -1517,7 +1523,7 @@ signaled condition to *HTML-OUTPUT*." (cond (shortform (values "Shortform" "shortform" (if (logged-in-userid) (lambda () (comment-controls :standalone t))))) (t (values (case view (:alignment-forum "Alignment Forum recent comments") (t "Recent comments")) "allRecentComments" nil))) - (multiple-value-bind (recent-comments total) + (multiple-value-bind (recent-comments total last-modified) (if (or (not (eq index-type :recent-comments)) offset limit view (/= (user-pref :items-per-page) 20)) (let ((*use-alignment-forum* (eq view :alignment-forum))) (lw2-graphql-query (lw2-query-string :comment :list @@ -1527,6 +1533,7 @@ signaled condition to *HTML-OUTPUT*." :context (if shortform :shortform :index) :with-total want-total))) (get-recent-comments :with-total want-total)) + (handle-last-modified last-modified) (renderer () (view-items-index recent-comments :title title @@ -1707,7 +1714,7 @@ signaled condition to *HTML-OUTPUT*." (show-text (if (not (eq show :all)) (string-capitalize show))) (title (format nil "~A~@['s ~A~]" display-name show-text)) (sort-type (case sort (:top :score) (:new :date) (:old :date-reverse)))) - (multiple-value-bind (items total) + (multiple-value-bind (items total last-modified) (case show (:posts (get-user-page-items user-id :posts :offset offset :limit (+ 1 (user-pref :items-per-page)) :sort-type sort-type)) @@ -1778,6 +1785,7 @@ signaled condition to *HTML-OUTPUT*."

This may mean your login token has expired or become invalid. You can try logging in again.

))) (t (get-user-page-items user-id :both :offset offset :limit (+ 1 (user-pref :items-per-page)) :sort-type sort-type))) + (handle-last-modified last-modified) (let ((with-next (> (length items) (+ (if (eq show :all) offset 0) (user-pref :items-per-page)))) (interleave (if (eq show :all) (comment-post-interleave items :limit (user-pref :items-per-page) :offset (if (eq show :all) offset nil) :sort-by sort-type) (firstn items (user-pref :items-per-page))))) ; this destructively sorts items (view-items-index interleave :title title diff --git a/src/backend.lisp b/src/backend.lisp index c303217d..647bff78 100644 --- a/src/backend.lisp +++ b/src/backend.lisp @@ -41,7 +41,8 @@ #:define-index-fields #:decode-graphql-json #:lw2-graphql-query-noparse #:lw2-graphql-query-streamparse #:*cookie-jar* - #:with-connection-pool #:call-with-connection-pool)) + #:with-connection-pool #:call-with-connection-pool + #:cache-is-fresh)) (in-package #:lw2.backend) @@ -92,7 +93,7 @@ (backend-alignment-forum (append (call-next-method) '(:af-karma :full-name)))) (define-cache-database 'backend-lw2-legacy - "index-json" + "index-json" "index-json-meta" "post-comments-json" "post-comments-json-meta" "post-answers-json" "post-answers-json-meta" "post-body-json" "post-body-json-meta" "sequence-json" "sequence-json-meta" "post-sequence" @@ -280,17 +281,18 @@ (define-backend-function fixup-lw2-return-value (value) (backend-base - value) + (values value nil)) (backend-lw2-modernized - (values-list - (map 'list - (lambda (x) - (if (member (car x) '(:result :results :total-count)) - (cdr x) - x)) - value))) + (values + (let ((x (first value))) + (if (member (car x) '(:result :results)) + (cdr x) + x)) + (let ((x (second value))) + (if (eq (car x) :total-count) + (cdr x))))) (backend-accordius - value)) + (values value nil))) (define-backend-function deserialize-query-result (result-source) (backend-base @@ -399,7 +401,8 @@ current-time))) (cache-put meta-db key (alist :last-checked current-time :last-modified last-mod :city-128-hash new-hash) :value-type :lisp) (unless same-data - (cache-put cache-db key data)))))) + (cache-put cache-db key data)) + (values data (unix-to-universal-time last-mod)))))) (defun cache-mark-stale (cache-db key) (let ((meta-db (format nil "~A-meta" cache-db)) @@ -413,16 +416,21 @@ (defparameter *cache-stale-factor* 100) (defparameter *cache-skip-factor* 5000) -(defun cache-is-fresh (cache-db key) - (let ((metadata (cache-get (format nil "~A-meta" cache-db) key :value-type :lisp)) - (current-time (get-unix-time))) - (if-let ((last-mod (cdr (assoc :last-modified metadata))) - (last-checked (cdr (assoc :last-checked metadata)))) - (let ((unmodified-time (- last-checked last-mod)) - (last-checked-time (- current-time last-checked))) - (if (> unmodified-time (* *cache-skip-factor* last-checked-time)) - :skip - (> unmodified-time (* *cache-stale-factor* last-checked-time))))))) +(defun cache-freshness-status (cache-db key) + (with-cache-readonly-transaction + (when (cache-exists cache-db key) + (let ((metadata (cache-get (format nil "~A-meta" cache-db) key :value-type :lisp)) + (current-time (get-unix-time))) + (if-let ((last-mod (cdr (assoc :last-modified metadata))) + (last-checked (cdr (assoc :last-checked metadata)))) + (values + (let ((unmodified-time (- last-checked last-mod)) + (last-checked-time (- current-time last-checked))) + (if (> unmodified-time (* *cache-skip-factor* last-checked-time)) + :skip + (> unmodified-time (* *cache-stale-factor* last-checked-time)))) + t + (unix-to-universal-time last-mod))))))) (defgeneric run-query (query) (:method ((query string)) @@ -444,12 +452,13 @@ (let ((key (format nil "~A-~A" cache-db cache-key))) (labels ((background-fn () (unwind-protect - (multiple-value-bind (value error) - (log-and-ignore-errors - (sb-sys:with-deadline (:seconds 60) - (nth-value 0 - (cache-update cache-db cache-key (run-query query))))) - (or value error)) + (block nil + (multiple-value-bind (value error) + (log-and-ignore-errors + (sb-sys:with-deadline (:seconds 60) + (return (cache-update cache-db cache-key (run-query query))))) + (declare (ignore value)) + (return error))) (remhash key *background-cache-update-threads*)))) (sb-ext:with-locked-hash-table (*background-cache-update-threads*) (let ((thread (gethash key *background-cache-update-threads*))) @@ -460,11 +469,12 @@ (define-backend-function lw2-graphql-query-timeout-cached (query cache-db cache-key &key (decoder 'decode-query-result) (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*)) (backend-base - (multiple-value-bind (cached-result is-fresh) (with-cache-readonly-transaction - (values (cache-exists cache-db cache-key) - (cache-is-fresh cache-db cache-key))) + (multiple-value-bind (is-fresh cached-result last-modified) + (cache-freshness-status cache-db cache-key) (labels ((get-cached-result () - (with-cache-readonly-transaction (funcall decoder (cache-get cache-db cache-key :return-type 'binary-stream))))) + (multiple-value-bind (result count) + (with-cache-readonly-transaction (funcall decoder (cache-get cache-db cache-key :return-type 'binary-stream))) + (values result count last-modified)))) (if (and cached-result (or (not revalidate) (and (not force-revalidate) (eq is-fresh :skip)))) (get-cached-result) @@ -480,10 +490,13 @@ (declare (ignore c)) (if cached-result (return-from retrieve-result (get-cached-result)))))) - (let ((new-result (sb-thread:join-thread thread :timeout timeout))) + (multiple-value-bind (new-result last-modified) + (sb-thread:join-thread thread :timeout timeout) (typecase new-result (condition (error new-result)) - (t (funcall decoder new-result))))))))))))) + (t (multiple-value-bind (result count) + (funcall decoder new-result) + (values result count last-modified)))))))))))))) (define-backend-function lw2-query-string* (query-type return-type args &key context fields with-total)) @@ -537,14 +550,20 @@ (lw2-graphql-query (apply 'lw2-query-string query-type :list terms (filter-plist rest :fields :context)) :auth-token auth-token))) (defun get-cached-index-query (cache-id query) - (labels ((query-and-put () - (let* ((result (lw2-graphql-query query :return-type :string)) - (decoded-result (multiple-value-list (decode-query-result result)))) - (cache-put "index-json" cache-id result) - (values-list decoded-result))) - (get-cached-result () - (with-cache-readonly-transaction (decode-query-result (cache-get "index-json" cache-id :return-type 'binary-stream))))) - (let ((cached-result (cache-get "index-json" cache-id :return-type 'existence))) + (multiple-value-bind (is-fresh cached-result last-modified) + (cache-freshness-status "index-json" cache-id) + (declare (ignore is-fresh)) + (labels ((query-and-put () + (multiple-value-bind (encoded-result last-modified) + (cache-update "index-json" cache-id (lw2-graphql-query query :return-type :string)) + (multiple-value-bind (result count) + (decode-query-result encoded-result) + (values result count last-modified)))) + (get-cached-result () + (with-cache-readonly-transaction + (multiple-value-bind (result count) + (decode-query-result (cache-get "index-json" cache-id :return-type 'binary-stream)) + (values result count last-modified))))) (if (and cached-result (background-loader-ready-p)) (get-cached-result) (if cached-result diff --git a/src/background-loader.lisp b/src/background-loader.lisp index f615e514..43de88a3 100644 --- a/src/background-loader.lisp +++ b/src/background-loader.lisp @@ -23,7 +23,7 @@ (posts-list (decode-query-result posts-json))) (when posts-list (with-cache-transaction - (cache-put "index-json" "new-not-meta" posts-json) + (cache-update "index-json" "new-not-meta" posts-json) (dolist (post posts-list) (cache-put "postid-to-title" (cdr (assoc :--id post)) (cdr (assoc :title post)))) (dolist (post posts-list) @@ -37,7 +37,7 @@ (log-and-ignore-errors (let ((recent-comments-json (sb-sys:with-deadline (:seconds 120) (get-recent-comments-json)))) (when-let ((recent-comments (ignore-errors (decode-query-result recent-comments-json)))) - (cache-put "index-json" "recent-comments" recent-comments-json) + (cache-update "index-json" "recent-comments" recent-comments-json) (loop for comment in recent-comments as comment-id = (cdr (assoc :--id comment)) as cache-database = (if (or (cdr (assoc :answer comment)) (cdr (assoc :parent-answer-id comment))) diff --git a/src/utils.lisp b/src/utils.lisp index 092c2f52..466f2476 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -5,7 +5,7 @@ #:alist-without-null #:alist-without-null* #:dynamic-let #:dynamic-let* #:dynamic-flet #:dynamic-labels #:with-semaphore - #:universal-time-to-unix #:get-unix-time #:as-timestamp #:timerange + #:universal-time-to-unix #:unix-to-universal-time #:get-unix-time #:as-timestamp #:timerange #:substring #:nonempty-string #:with-delimited-writer #:regex-groups-min @@ -120,6 +120,9 @@ (defun universal-time-to-unix (time) (- time #.(encode-universal-time 0 0 0 1 1 1970 0))) +(defun unix-to-universal-time (unix-time) + (+ unix-time #.(encode-universal-time 0 0 0 1 1 1970 0))) + (defun get-unix-time () (universal-time-to-unix (get-universal-time))) -- 2.11.4.GIT