Revert "Add warning about EA Forum login problem."
[lw2-viewer.git] / src / backend.lisp
blobb8b69ae39dd0883bff77f7204ab3de4b7d8b0007
1 (uiop:define-package #:lw2.backend
2 (:use #:cl #:sb-thread #:flexi-streams #:alexandria #:iterate #:lw2-viewer.config #:lw2.sites #:lw2.context #:lw2.graphql #:lw2.lmdb
3 #:lw2.utils #:lw2.hash-utils #:lw2.backend-modules #:lw2.schema-type #:lw2.conditions #:lw2.web-push)
4 (:import-from #:collectors #:with-collector)
5 (:import-from #:lw2.user-context #:*current-auth-token*)
6 (:reexport #:lw2.backend-modules)
7 (:export #:*use-alignment-forum*
8 #:*graphql-debug-output*
9 #:*revalidate-default* #:*force-revalidate-default*
10 #:*messages-index-fields*
11 #:*notifications-base-terms*
12 #:*enable-rate-limit*
13 #:start-background-loader #:stop-background-loader #:background-loader-running-p
14 #:call-with-http-response
15 #:forwarded-header #:backend-request-headers
16 #:lw2-graphql-query #:lw2-query-string* #:lw2-query-string
17 #:lw2-graphql-query-map #:lw2-graphql-query-multi
18 #:signal-lw2-errors
19 #:earliest-post-time
20 #:flatten-shortform-comments #:get-shortform-votes
21 #:get-tag-posts
22 #:get-post-tag-votes #:get-tag-post-votes
23 #:get-slug-tagid
24 #:get-posts-index #:get-posts-json #:get-post-body #:get-post-vote #:get-post-comments #:get-post-answers
25 #:get-post-comments-votes
26 #:get-tag-comments-votes
27 #:get-recent-comments #:get-recent-comments-json
28 #:get-collection
29 #:sequence-post-ids #:get-sequence #:get-post-sequence-ids #:get-sequence-post
30 #:get-conversation-messages
31 #:markdown-source
32 #:get-user
33 #:get-notifications #:check-notifications
34 #:mark-comment-replied #:check-comment-replied
35 #:lw2-search-query #:get-post-title #:get-post-slug #:get-slug-postid #:get-username #:get-user-full-name #:get-user-slug
36 #:do-wl-rest-mutate #:do-wl-rest-query #:do-wl-create-tag)
37 (:recycle #:lw2-viewer)
38 (:unintern #:get-posts #:make-posts-list-query #:define-backend-fields
39 #:*posts-index-fields* #:posts-index-fields #:post-body-fields
40 #:*comments-index-fields* #:comments-index-fields
41 #:*post-comments-fields* #:post-comments-fields
42 #:define-index-fields #:decode-graphql-json
43 #:lw2-graphql-query-noparse #:lw2-graphql-query-streamparse
44 #:*cookie-jar*
45 #:with-connection-pool #:call-with-connection-pool
46 #:cache-is-fresh))
48 (in-package #:lw2.backend)
50 ;; Dexador settings required for the system to work properly.
51 (setf dex:*default-connect-timeout* nil
52 dex:*default-read-timeout* nil
53 dex:*use-connection-pool* nil)
55 (defvar *use-alignment-forum* nil)
57 (defvar *graphql-debug-output* nil)
59 (defvar *revalidate-default* t)
60 (defvar *force-revalidate-default* nil)
62 (defparameter *messages-index-fields* '(:--id :user-id :created-at (:contents :html) (:conversation :--id :title) :----typename))
63 (defparameter *user-fields* '(:--id :slug :display-name :karma))
65 (defparameter *notifications-base-terms* (alist :view "userNotifications" :created-at :null :viewed :null))
67 (defun request-fields (query-type return-type context)
68 "Returns the desired fields for a given type of request."
69 (case return-type
70 (:total nil)
72 (with-collector (col)
73 (let ((backend *current-backend*)
74 (schema-type (find-schema-type query-type))
75 (added (make-hash-table :test 'eq)))
76 (dolist (field (cdr (assoc :fields schema-type)) (col))
77 (destructuring-bind (field-name field-type &key alias backend-type graphql-ignore subfields ((:context field-context)) context-not &allow-other-keys) field
78 (declare (ignore field-type))
79 (when (and (not (gethash field-name added))
80 (not graphql-ignore)
81 (or (not backend-type) (typep backend backend-type))
82 (or (not field-context) (eq context field-context))
83 (or (not context-not) (not (eq context context-not))))
84 (setf (gethash field-name added) t)
85 (col
86 (let ((result-name (or alias field-name)))
87 (if subfields
88 (list* result-name subfields)
89 result-name)))))))))))
91 (define-backend-function user-fields ()
92 (backend-lw2-legacy (load-time-value *user-fields*))
93 (backend-lw2-modernized (append (call-next-method) '(:groups :deleted :html-bio)))
94 (backend-alignment-forum (append (call-next-method) '(:af-karma :full-name))))
96 (define-cache-database 'backend-lw2-legacy
97 "index-json" "index-json-meta"
98 "post-comments-json" "post-comments-json-meta" "post-answers-json" "post-answers-json-meta"
99 "post-body-json" "post-body-json-meta"
100 "sequence-json" "sequence-json-meta" "post-sequence"
101 "user-json" "user-json-meta"
102 "user-page-items" "user-page-items-meta")
104 (define-cache-database 'backend-lw2-modernized
105 "user-deleted")
107 (define-backend-function comments-list-to-graphql-json (comments-list)
108 (backend-lw2-legacy
109 (json:encode-json-to-string
110 (plist-hash-table (list :data (plist-hash-table (list :*comments-list comments-list))))))
111 (backend-lw2-modernized
112 (json:encode-json-to-string
113 (plist-hash-table (list :data (plist-hash-table (list :*comments-list (plist-hash-table (list :results comments-list)))))))))
115 (defun do-graphql-debug (query)
116 (when *graphql-debug-output*
117 (format *graphql-debug-output* "~&GraphQL query: ~A~%" query)))
119 (defmacro with-retrying ((maybe-retry-fn-name &key retries before-maybe-retry before-retry) &body body)
120 (with-gensyms (remaining-retries retry)
121 `(let ((,remaining-retries ,retries))
122 (tagbody ,retry
123 (labels ((,maybe-retry-fn-name ()
124 ,before-maybe-retry
125 (when (> ,remaining-retries 0)
126 (decf ,remaining-retries)
127 ,before-retry
128 (go ,retry))))
129 ,@body)))))
131 (defun force-close (stream)
132 (ignore-errors (close stream :abort t)))
134 (sb-ext:defglobal *connection-pool* (make-hash-table :test 'equal))
135 (sb-ext:defglobal *connection-pool-lock* (sb-thread:make-mutex :name "*connection-pool-lock*"))
137 (defun connection-push (dest connection)
138 (let ((connection-pool *connection-pool*)
139 old-connection)
140 (sb-thread:with-mutex (*connection-pool-lock*)
141 (let ((vector (or (gethash dest connection-pool)
142 (setf (gethash dest connection-pool)
143 (make-array 4 :fill-pointer 0)))))
144 (unless (vector-push connection vector)
145 (setf old-connection (vector-pop vector))
146 (vector-push connection vector))))
147 (when old-connection
148 (force-close old-connection))))
150 (defun connection-pop (dest)
151 (let ((connection-pool *connection-pool*))
152 (sb-thread:with-mutex (*connection-pool-lock*)
153 (when-let (vector (gethash dest connection-pool))
154 (when (> (fill-pointer vector) 0)
155 (vector-pop vector))))))
157 (eval-when (:compile-toplevel :load-toplevel :execute)
158 (defstruct (token-bucket (:constructor %make-token-bucket))
159 (tokens internal-time-units-per-second :type fixnum)
160 (base-cost internal-time-units-per-second :type fixnum)
161 (last-update (get-internal-real-time) :type fixnum)
162 (tokens-per-unit 1 :type fixnum)
163 (token-limit internal-time-units-per-second :type fixnum))
165 (defun make-token-bucket (&key rate burst (fill-ratio 1.0))
166 (let* ((scaled-rate (rationalize (/ internal-time-units-per-second rate)))
167 (base-cost (numerator scaled-rate))
168 (tokens-per-unit (denominator scaled-rate))
169 (token-limit (* base-cost burst)))
170 (%make-token-bucket
171 :base-cost base-cost
172 :tokens-per-unit tokens-per-unit
173 :token-limit token-limit
174 :tokens (round (* token-limit fill-ratio))))))
176 (defun token-bucket-decrement (token-bucket n &optional with-punishment)
177 (let* ((time (get-internal-real-time))
178 (tpu (token-bucket-tokens-per-unit token-bucket))
179 (limit (token-bucket-token-limit token-bucket))
180 (cost (round (* n (token-bucket-base-cost token-bucket))))
181 (max-increment (+ limit cost))
182 (max-timediff (ceiling max-increment tpu))
183 (increment 0)
184 (result nil))
185 (declare (type (and fixnum (integer 0)) time)
186 (type (unsigned-byte 32) limit cost max-increment increment)
187 (type (integer 1 10000000) tpu))
188 (sb-ext:atomic-update (token-bucket-last-update token-bucket)
189 (lambda (previous)
190 (declare (type (and fixnum (integer 0)) previous))
191 (if (> (- time max-timediff) previous)
192 (setf increment max-increment)
193 (let ((timediff (- time (min previous time))))
194 (declare (type (unsigned-byte 32) timediff))
195 (setf increment (* timediff tpu))))
196 (max previous time)))
197 (sb-ext:atomic-update (token-bucket-tokens token-bucket)
198 (lambda (previous)
199 (declare (type (signed-byte 32) previous))
200 (let* ((new-refill (+ previous increment))
201 (new (- new-refill cost)))
202 (setf result (> new 0))
203 (if (or result with-punishment)
204 (min new limit)
205 (max (- limit) (min new-refill limit))))))
206 result))
208 (defun parse-ipv4 (string)
209 (let ((l (map 'list #'parse-integer
210 (split-sequence:split-sequence #\. string))))
211 (loop with res = 0
212 for n in l
213 do (setf res (+ n (ash res 8)))
214 finally (return res))))
216 (defvar *enable-rate-limit* t)
218 (defparameter *rate-limit-cost-factor* 1)
220 (sb-ext:defglobal *global-token-bucket* (make-token-bucket :rate 3 :burst 180))
222 (defun check-rate-limit ()
223 (or (token-bucket-decrement *global-token-bucket* *rate-limit-cost-factor*)
224 (error "Rate limit exceeded. Try again later.")))
226 (defun call-with-http-response (fn uri-string &rest args &key &allow-other-keys)
227 (when *enable-rate-limit*
228 (check-rate-limit))
229 (let* ((uri (quri:uri uri-string))
230 (uri-dest (concatenate 'string (quri:uri-host uri) ":" (format nil "~d" (quri:uri-port uri))))
231 (stream (connection-pop uri-dest)))
232 (let (response status-code headers response-uri new-stream success)
233 (with-retrying (maybe-retry :retries 3
234 :before-retry (sleep 0.2))
235 (unwind-protect
236 (handler-bind (((or dex:http-request-failed usocket:ns-condition usocket:socket-condition)
237 (lambda (condition)
238 (if-let ((r (find-restart 'dex:ignore-and-continue condition))
239 (ct (gethash "content-type" (dex:response-headers condition))))
240 (if (ppcre:scan "^application/json" ct)
241 (invoke-restart r)
242 (maybe-retry))))))
243 (setf (values response status-code headers response-uri new-stream)
244 (apply 'dex:request uri :use-connection-pool nil :keep-alive t :stream stream args))
245 (unless (eq stream new-stream)
246 (when stream (force-close stream))
247 (setf stream new-stream
248 new-stream nil))
249 (when (<= 500 status-code 599)
250 (maybe-retry)
251 (error 'lw2-connection-error :message (format nil "HTTP status ~A" status-code)))
252 (setf success t))
253 (when (not success)
254 (when (streamp response)
255 (force-close response))
256 (when stream
257 (force-close stream))
258 (setf stream nil))))
259 (unwind-protect
260 (funcall fn response)
261 (when (streamp response)
262 (close response))
263 (when stream ; the connection is reusable
264 (connection-push uri-dest stream))))))
266 (defun forwarded-header ()
267 (let ((addr (and (boundp 'hunchentoot:*request*) (hunchentoot:real-remote-addr))))
268 (list-cond (addr "X-Forwarded-For" addr))))
270 (defun signal-lw2-errors (errors)
271 (loop for error in errors
272 do (let ((message (cdr (assoc :message error)))
273 (path (cdr (assoc :path error))))
274 (unless (and path (> (length path) 1))
275 (cond
276 ((search "document_not_found" message) (error 'lw2-not-found-error))
277 ((search "app.missing_document" message) (error 'lw2-not-found-error))
278 ((search "only visible to logged-in users" message) (error 'lw2-login-required-error))
279 ((search "not_allowed" message) (error 'lw2-not-allowed-error))
280 (t (error 'lw2-unknown-error :message message)))))))
282 (define-backend-function earliest-post-time ()
283 (backend-lw2 (load-time-value (local-time:parse-timestring "2005-01-01")))
284 (backend-ea-forum (load-time-value (local-time:parse-timestring "2011-11-24"))))
286 (define-backend-function fixup-lw2-return-value (value)
287 (backend-base
288 (values value nil))
289 (backend-lw2-modernized
290 (values
291 (let ((x (first value)))
292 (if (member (car x) '(:result :results))
293 (cdr x)
295 (let ((x (second value)))
296 (if (eq (car x) :total-count)
297 (cdr x)))))
298 (backend-accordius
299 (values value nil)))
301 (define-backend-function deserialize-query-result (result-source)
302 (backend-base
303 (let ((string-source (typecase result-source
304 (string
305 result-source)
306 (vector
307 (flexi-streams:make-in-memory-input-stream result-source))
308 (stream
309 (ensure-character-stream result-source)))))
310 (json:decode-json-from-source string-source))))
312 (define-backend-function postprocess-query-result (result)
313 (backend-base
314 result)
315 (backend-lw2-legacy
316 (signal-lw2-errors (cdr (assoc :errors result)))
317 (fixup-lw2-return-value (cdadr (assoc :data result)))))
319 (define-backend-function decode-query-result (result-source)
320 (backend-base
321 (postprocess-query-result
322 (deserialize-query-result result-source))))
324 (defmethod graphql-uri ((backend backend-alignment-forum))
325 (if *use-alignment-forum*
326 "https://www.alignmentforum.org/graphql"
327 (call-next-method)))
329 (define-backend-function backend-request-headers (auth-token forwarded)
330 (backend-websocket-login
331 (list-cond* (auth-token :authorization auth-token)
332 (call-next-method)))
333 (backend-passport-js-login
334 (list-cond* (auth-token :cookie (concatenate 'string "loginToken=" auth-token))
335 (call-next-method)))
336 (backend-graphql
337 (alist* :content-type "application/json"
338 (if forwarded (forwarded-header)))))
340 (define-backend-function call-with-backend-response (fn query &key return-type auth-token)
341 (backend-graphql
342 (call-with-http-response
344 (graphql-uri *current-backend*)
345 :method :post
346 :headers (backend-request-headers auth-token nil)
347 :content (dynamic-let ((q (alist :query query))) (json:encode-json-to-string q))
348 :want-stream (not return-type))))
350 (define-backend-function lw2-graphql-query (query &key auth-token return-type (decoder 'decode-query-result))
351 (backend-base
352 (do-graphql-debug query)
353 (call-with-backend-response
354 (ecase return-type
355 ((nil) decoder)
356 (:string #'identity)
357 (:both (lambda (string) (values (funcall decoder string) string))))
358 query
359 :return-type return-type
360 :auth-token auth-token)))
362 (defun lw2-graphql-query-map (fn data &key auth-token postprocess)
363 (multiple-value-bind (map-values queries)
364 (loop for d in data
365 as out-values = (multiple-value-list (funcall fn d))
366 as (out passthrough-p) = out-values
367 collect out-values into map-values
368 when (not passthrough-p) collect out into queries
369 finally (return (values map-values queries)))
370 (let* ((query-string
371 (with-output-to-string (stream)
372 (format stream "{")
373 (loop for n from 0
374 for q in queries
375 do (format stream "g~6,'0D:~A " n q))
376 (format stream "}")))
377 (query-result-data (when queries (lw2-graphql-query query-string :decoder 'deserialize-query-result :auth-token auth-token)))
378 (errors (cdr (assoc :errors query-result-data))))
379 (signal-lw2-errors errors)
380 (values
381 (loop as results = (sort (cdr (assoc :data query-result-data)) #'string< :key #'car) then (if passthrough-p results (rest results))
382 for (out passthrough-p) in map-values
383 as result-data-cell = (first results)
384 as result-data = (if passthrough-p out (fixup-lw2-return-value (cdr result-data-cell)))
385 for input-data in data
386 collect (if postprocess (funcall postprocess input-data result-data) result-data))
387 errors))))
389 (defun lw2-graphql-query-multi (query-list &key auth-token)
390 (values-list (lw2-graphql-query-map #'identity query-list :auth-token auth-token)))
392 (defvar *background-cache-update-threads* (make-hash-table :test 'equal
393 :weakness :value
394 :synchronized t))
396 (defvar *parsed-results-cache* (make-hash-table :test 'equal
397 :weakness :value
398 :synchronized t))
400 (defun cache-update (cache-db key data)
401 (let ((meta-db (format nil "~A-meta" cache-db))
402 (new-hash (hash-string data))
403 (current-time (get-unix-time)))
404 (with-cache-transaction
405 (let* ((metadata (cache-get meta-db key :value-type :lisp))
406 (same-data (equalp new-hash (cdr (assoc :city-128-hash metadata))))
407 (last-mod (if same-data
408 (or (cdr (assoc :last-modified metadata)) current-time)
409 current-time)))
410 (cache-put meta-db key (alist :last-checked current-time :last-modified last-mod :city-128-hash new-hash) :value-type :lisp)
411 (unless same-data
412 (remhash (list *current-backend* cache-db key) *parsed-results-cache*)
413 (cache-put cache-db key data))
414 (values data (unix-to-universal-time last-mod))))))
416 (defun cache-mark-stale (cache-db key)
417 (let ((meta-db (format nil "~A-meta" cache-db))
418 (current-time (get-unix-time)))
419 (with-cache-transaction
420 (let* ((metadata (cache-get meta-db key :value-type :lisp))
421 (metadata (alist* :last-modified current-time (delete :last-modified metadata :key #'car))))
422 (cache-put meta-db key metadata :value-type :lisp)))))
424 (declaim (type (and fixnum (integer 1)) *cache-stale-factor* *cache-skip-factor*))
425 (defparameter *cache-stale-factor* 100)
426 (defparameter *cache-skip-factor* 5000)
428 (defun cache-freshness-status (cache-db key)
429 (with-cache-readonly-transaction
430 (when (cache-exists cache-db key)
431 (let ((metadata (cache-get (format nil "~A-meta" cache-db) key :value-type :lisp))
432 (current-time (get-unix-time)))
433 (if-let ((last-mod (cdr (assoc :last-modified metadata)))
434 (last-checked (cdr (assoc :last-checked metadata))))
435 (values
436 (let ((unmodified-time (- last-checked last-mod))
437 (last-checked-time (- current-time last-checked)))
438 (if (> unmodified-time (* *cache-skip-factor* last-checked-time))
439 :skip
440 (> unmodified-time (* *cache-stale-factor* last-checked-time))))
442 (unix-to-universal-time last-mod)))))))
444 (defgeneric run-query (query)
445 (:method ((query string))
446 (lw2-graphql-query query :return-type :string))
447 (:method ((query function))
448 (funcall query)))
450 (declaim (inline make-thread-with-current-backend))
452 (defun make-thread-with-current-backend (fn &rest args)
453 (let ((current-backend *current-backend*))
454 (apply #'sb-thread:make-thread
455 (lambda ()
456 (let ((*current-backend* current-backend))
457 (funcall fn)))
458 args)))
460 (defun ensure-cache-update-thread (query cache-db cache-key)
461 (let ((key (format nil "~A-~A" cache-db cache-key)))
462 (labels ((background-fn ()
463 (unwind-protect
464 (block nil
465 (multiple-value-bind (value error)
466 (log-and-ignore-errors
467 (sb-sys:with-deadline (:seconds 60)
468 (return (cache-update cache-db cache-key (run-query query)))))
469 (declare (ignore value))
470 (return error)))
471 (remhash key *background-cache-update-threads*))))
472 (sb-ext:with-locked-hash-table (*background-cache-update-threads*)
473 (let ((thread (gethash key *background-cache-update-threads*)))
474 (if thread thread
475 (setf (gethash key *background-cache-update-threads*)
476 (make-thread-with-current-backend #'background-fn :name "background cache update"))))))))
478 (define-backend-function lw2-graphql-query-timeout-cached (query cache-db cache-key &key (decoder 'decode-query-result)
479 (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
480 (backend-base
481 (multiple-value-bind (is-fresh cached-result last-modified)
482 (cache-freshness-status cache-db cache-key)
483 (labels ((get-cached-result ()
484 (if-let ((parsed-result (gethash (list *current-backend* cache-db cache-key) *parsed-results-cache*)))
485 (multiple-value-call #'values (values-list parsed-result) last-modified)
486 (multiple-value-bind (result count)
487 (with-cache-readonly-transaction (funcall decoder (cache-get cache-db cache-key :return-type 'binary-stream)))
488 (setf (gethash (list *current-backend* cache-db cache-key) *parsed-results-cache*) (list result count))
489 (values result count last-modified)))))
490 (if (and cached-result (or (not revalidate)
491 (and (not force-revalidate) (eq is-fresh :skip))))
492 (get-cached-result)
493 (let ((timeout (if cached-result
494 (if force-revalidate nil 3)
495 nil))
496 (thread (ensure-cache-update-thread query cache-db cache-key)))
497 (block retrieve-result
498 (if (and cached-result (if force-revalidate (not revalidate) (or is-fresh (not revalidate))))
499 (get-cached-result)
500 (handler-bind
501 ((fatal-error (lambda (c)
502 (declare (ignore c))
503 (if cached-result
504 (return-from retrieve-result (get-cached-result))))))
505 (multiple-value-bind (new-result last-modified)
506 (sb-thread:join-thread thread :timeout timeout)
507 (typecase new-result
508 (condition (error new-result))
509 (t (multiple-value-bind (result count)
510 (funcall decoder new-result)
511 (setf (gethash (list *current-backend* cache-db cache-key) *parsed-results-cache*) (list result count))
512 (values result count last-modified))))))))))))))
514 (define-backend-function lw2-query-string* (query-type return-type args &key context fields with-total))
516 (define-backend-operation lw2-query-string* backend-lw2-legacy (query-type return-type args &key context (fields (request-fields query-type return-type context)) with-total)
517 (declare (ignore with-total))
518 (labels ((lisp-to-lw2-case (x) (json:lisp-to-camel-case (format nil "*~A" x))))
519 (graphql-query-string*
520 (concatenate 'string
521 (lisp-to-lw2-case query-type)
523 (lisp-to-lw2-case return-type))
524 (if (eq return-type :single)
525 args
526 (alist :terms args))
527 fields)))
529 (define-backend-operation lw2-query-string* backend-lw2-modernized (query-type return-type args &key context (fields (request-fields query-type return-type context)) with-total)
530 (graphql-query-string*
531 (if (eq return-type :single)
532 (json:lisp-to-camel-case (string query-type))
533 (concatenate 'string (json:lisp-to-camel-case (string query-type)) "s"))
534 (alist :input (case return-type
535 (:single (alist :selector args))
536 (:list (alist :enable-total with-total :terms args))
537 (:total (alist :enable-total t :terms args))))
538 (case return-type
539 (:total '(:total-count))
540 (:list (list-cond (t :results fields)
541 (with-total :total-count)))
542 (:single (alist :result fields)))))
544 (define-backend-function lw2-query-string (query-type return-type args &key context fields with-total))
546 (define-backend-operation lw2-query-string backend-lw2-legacy (query-type return-type args &rest rest &key context fields with-total)
547 (declare (ignore context fields with-total))
548 (format nil "{~A}" (apply 'lw2-query-string* query-type return-type args rest)))
550 (define-backend-function lw2-query-list-limit-workaround (query-type terms &rest rest &key fields context auth-token)
551 (backend-graphql
552 (declare (ignore fields context))
553 (let (items-list)
554 (loop for offset from 0 by 500
555 as items-next = (lw2-graphql-query (apply 'lw2-query-string query-type :list (alist* :limit 500 :offset offset terms) (filter-plist rest :fields :context))
556 :auth-token auth-token)
557 as length = (length items-next)
558 do (setf items-list (nconc items-list items-next))
559 while (>= length 500))
560 items-list))
561 (backend-accordius
562 (declare (ignore fields context))
563 (lw2-graphql-query (apply 'lw2-query-string query-type :list terms (filter-plist rest :fields :context)) :auth-token auth-token)))
565 (defun get-cached-index-query (cache-id query)
566 (multiple-value-bind (is-fresh cached-result last-modified)
567 (cache-freshness-status "index-json" cache-id)
568 (declare (ignore is-fresh))
569 (labels ((query-and-put ()
570 (multiple-value-bind (encoded-result last-modified)
571 (cache-update "index-json" cache-id (lw2-graphql-query query :return-type :string))
572 (multiple-value-bind (result count)
573 (decode-query-result encoded-result)
574 (values result count last-modified))))
575 (get-cached-result ()
576 (with-cache-readonly-transaction
577 (multiple-value-bind (result count)
578 (decode-query-result (cache-get "index-json" cache-id :return-type 'binary-stream))
579 (values result count last-modified)))))
580 (if (and cached-result (background-loader-ready-p))
581 (get-cached-result)
582 (if cached-result
583 (handler-case
584 (query-and-put)
585 (t () (get-cached-result)))
586 (query-and-put))))))
588 (define-backend-function get-posts-index-query-terms (&key view (sort "new") (limit 21) offset before after karma-threshold &allow-other-keys)
589 (backend-lw2-legacy
590 (let ((sort-key (alexandria:switch (sort :test #'string=)
591 ("new" "new")
592 ("hot" "magic")
593 ("active" "recentComments")
594 ("top" "top")
595 ("old" "old"))))
596 (multiple-value-bind (view-terms cache-key)
597 (alexandria:switch (view :test #'string=)
598 ("featured" (alist :sorted-by sort-key :filter "curated"))
599 ("all" (alist :sorted-by sort-key :filter "all"))
600 ("alignment-forum" (alist :sorted-by sort-key :af t))
601 ("questions" (alist :sorted-by sort-key :filter "questions"))
602 ("events" (alist :sorted-by sort-key :filter "events"))
603 ("nominations" (alist :view "nominations2019"))
604 ("reviews" (alist :view "reviews2019"))
605 (t (values
606 (alist :sorted-by sort-key :filter "frontpage")
607 (if (not (or (string/= sort "new") (/= limit 21) offset before after karma-threshold)) "new-not-meta"))))
608 (let ((terms
609 (alist-without-null* :before before
610 :after after
611 :limit limit
612 :offset offset
613 :karma-threshold karma-threshold
614 view-terms)))
615 (values terms cache-key))))))
617 (define-backend-operation get-posts-index-query-terms backend-lw2-tags :around (&key hide-tags &allow-other-keys)
618 (multiple-value-bind (query-terms cache-key) (call-next-method)
619 (if hide-tags
620 (values (acons :filter-settings (alist :tags (list* :list (map 'list (lambda (tagid) (alist :tag-id tagid :filter-mode "Hidden"))
621 hide-tags)))
622 query-terms)
623 nil)
624 (values query-terms cache-key))))
626 (define-backend-function get-posts-index-query-string (&rest args &key &allow-other-keys)
627 (backend-lw2-legacy
628 (declare (dynamic-extent args))
629 (multiple-value-bind (query-terms cache-key)
630 (apply #'%get-posts-index-query-terms backend args)
631 (values (lw2-query-string :post :list query-terms)
632 cache-key))))
634 (define-backend-function get-posts-index (&rest args &key &allow-other-keys)
635 (backend-lw2-legacy
636 (declare (dynamic-extent args))
637 (multiple-value-bind (query-string cache-key)
638 (apply #'%get-posts-index-query-string backend args)
639 (if cache-key
640 (get-cached-index-query cache-key query-string)
641 (lw2-graphql-query query-string)))))
643 (define-backend-operation get-posts-index backend-lw2-tags :around (&rest args &key hide-tags offset (limit 21) &allow-other-keys)
644 ;; Workaround for https://github.com/LessWrong2/Lesswrong2/issues/3099
645 (declare (dynamic-extent args))
646 (if hide-tags
647 (let ((offset (or offset 0)))
648 (subseq
649 (apply #'call-next-method backend :offset 0 :limit (+ limit offset) args)
650 offset))
651 (call-next-method)))
653 (defun get-posts-json ()
654 (lw2-graphql-query (get-posts-index-query-string) :return-type :string))
656 (defun get-recent-comments (&key with-total)
657 (get-cached-index-query "recent-comments" (lw2-query-string :comment :list '((:view . "allRecentComments") (:limit . 20)) :context :index :with-total with-total)))
659 (defun get-recent-comments-json ()
660 (lw2-graphql-query (lw2-query-string :comment :list '((:view . "allRecentComments") (:limit . 20)) :context :index) :return-type :string))
662 (defun process-vote-result (res)
663 (alist-bind ((id (or null simple-string) :--id)
664 current-user-votes
665 current-user-vote
666 current-user-extended-vote)
668 (let ((karma-vote (or (nonempty-string current-user-vote)
669 (cdr (assoc :vote-type (first current-user-votes))))))
670 (values (list-cond* (karma-vote :karma karma-vote)
671 current-user-extended-vote)
672 id))))
674 (defun process-votes-result (res)
675 (let ((hash (make-hash-table)))
676 (dolist (v res hash)
677 (multiple-value-bind (vote id) (process-vote-result v)
678 (when vote
679 (setf (gethash id hash) vote))))))
681 (defun flatten-shortform-comments (comments)
682 (let ((output comments))
683 (loop for comment in comments do
684 (setf output (append (cdr (assoc :latest-children comment)) output)))
685 output))
687 (defun get-shortform-votes (auth-token &key (offset 0) (limit 20))
688 (process-votes-result
689 (flatten-shortform-comments
690 (lw2-graphql-query (lw2-query-string :comment :list (alist :view "shortform" :offset offset :limit limit)
691 :fields '(:--id :current-user-vote :current-user-extended-vote (:latest-children :--id :current-user-vote :current-user-extended-vote)))
692 :auth-token auth-token))))
694 (defun get-post-vote (post-id auth-token)
695 (process-vote-result (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) :fields '(:--id :current-user-vote :current-user-extended-vote)) :auth-token auth-token)))
697 (define-cache-database 'backend-lw2-tags "tag-posts" "tag-posts-meta" "post-tags" "post-tags-meta")
699 (define-backend-function get-tag-posts (slug &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
700 (backend-base (declare (ignore revalidate force-revalidate)) nil)
701 (backend-lw2-tags
702 (let* ((tagid (get-slug-tagid slug))
703 (query-fn (lambda ()
704 (comments-list-to-graphql-json
705 (lw2-query-list-limit-workaround
706 :tag-rel
707 (alist :view "postsWithTag" :tag-id tagid)
708 :fields (list (list* :post (request-fields :post :list :index))))))))
709 (iter
710 (for x in (lw2-graphql-query-timeout-cached query-fn "tag-posts" tagid :revalidate revalidate :force-revalidate force-revalidate))
711 (when-let (post (cdr (assoc :post x)))
712 (collect post))))))
714 (define-backend-function get-tag-post-votes (tag-id auth-token)
715 (backend-base (progn tag-id auth-token nil))
716 (backend-lw2-tags
717 (process-votes-result
718 (map 'list #'cdr
719 (lw2-query-list-limit-workaround
720 :tag-rel
721 (alist :view "postsWithTag" :tag-id tag-id)
722 :fields '(:--id :current-user-vote :current-user-extended-vote)
723 :auth-token auth-token)))))
725 (define-backend-function get-post-tags (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
726 (backend-base (declare (ignore revalidate force-revalidate)) nil)
727 (backend-lw2-tags
728 (let ((query-string (lw2-query-string :tag-rel :list (alist :view "tagsOnPost" :post-id post-id) :fields '((:tag :name :slug)))))
729 (lw2-graphql-query-timeout-cached query-string "post-tags" post-id :revalidate revalidate :force-revalidate force-revalidate))))
731 (define-backend-function get-post-tag-votes (post-id auth-token)
732 (backend-base (progn post-id auth-token nil))
733 (backend-lw2-tags
734 (process-votes-result
735 (lw2-graphql-query (lw2-query-string :tag-rel :list (alist :view "tagsOnPost" :post-id post-id) :fields '(:--id :current-user-vote :current-user-extended-vote))
736 :auth-token auth-token))))
738 (define-backend-function get-post-body (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
739 (backend-graphql
740 (let ((query-string (lw2-query-string :post :single (alist :document-id post-id) :context :body)))
741 (block nil
742 (tagbody retry
743 (handler-bind ((lw2-login-required-error (lambda (&rest args)
744 (declare (ignore args))
745 (let ((current-auth-token *current-auth-token*))
746 (when (and (not auth-token) current-auth-token)
747 (setf auth-token current-auth-token)
748 (go retry))))))
749 (return
750 (if auth-token
751 (lw2-graphql-query query-string :auth-token auth-token)
752 (lw2-graphql-query-timeout-cached query-string "post-body-json" post-id :revalidate revalidate :force-revalidate force-revalidate))))))))
753 (backend-lw2-tags
754 (declare (ignore auth-token))
755 (acons :tags (get-post-tags post-id :revalidate revalidate :force-revalidate force-revalidate) (call-next-method)))
756 (backend-magnum-crossposts
757 (declare (ignore auth-token))
758 (let ((post (call-next-method)))
759 (alist-bind (is-crosspost hosted-here foreign-post-id) (cdr (assoc :fm-crosspost post))
760 (cond ((not (and (backend-magnum-crosspost-site backend)
761 (not (boundp '*retrieve-crosspost*))
762 is-crosspost foreign-post-id))
763 post)
764 (:otherwise
765 (let* ((*current-site* (find-site (backend-magnum-crosspost-site backend)))
766 (*current-backend* (site-backend *current-site*))
767 (*retrieve-crosspost* nil)
768 (foreign-post (get-post-body foreign-post-id :revalidate revalidate :force-revalidate force-revalidate))
769 (foreign-post-body (cdr (assoc :html-body foreign-post))))
770 (declare (special *retrieve-crosspost*))
771 (if foreign-post-body
772 (list-cond*
773 ((not hosted-here) :html-body foreign-post-body)
774 (t :foreign-post foreign-post)
775 post)
776 post))))))))
778 (defun get-post-comments-list (post-id view &rest rest &key auth-token parent-answer-id fields context)
779 (declare (ignore fields context auth-token))
780 (let ((terms (alist :view view :post-id post-id)))
781 (when parent-answer-id
782 (setf terms (acons :parent-answer-id parent-answer-id terms)))
783 (apply 'lw2-query-list-limit-workaround :comment terms (filter-plist rest :fields :context :auth-token))))
785 (defun get-post-answer-replies (post-id answers &rest rest &key auth-token fields context)
786 ;; todo: support more than 500 answers per question
787 (declare (ignore fields context))
788 (let* ((terms (alist :view "repliesToAnswer" :post-id post-id :limit 500))
789 (result (lw2-graphql-query-map
790 #'identity
791 (mapcar (lambda (answer) (apply 'lw2-query-string* :comment :list
792 (acons :parent-answer-id (cdr (assoc :--id answer)) terms)
793 (filter-plist rest :fields :context)))
794 answers)
795 :auth-token auth-token)))
796 (apply #'nconc result)))
798 (define-backend-function get-post-comments-votes (post-id auth-token)
799 (backend-graphql
800 (let ((fields '(:--id :current-user-vote :current-user-extended-vote)))
801 (process-votes-result
802 (get-post-comments-list post-id "postCommentsTop" :auth-token auth-token :fields fields))))
803 (backend-q-and-a
804 (let* ((fields '(:--id :current-user-vote :current-user-extended-vote))
805 (answers (get-post-comments-list post-id "questionAnswers" :auth-token auth-token :fields fields)))
806 (process-votes-result
807 (nconc
808 (get-post-comments-list post-id "postCommentsTop" :auth-token auth-token :fields fields)
809 (get-post-answer-replies post-id answers :auth-token auth-token :fields fields)
810 answers)))))
812 (define-backend-function get-tag-comments-votes (tag-id auth-token)
813 (backend-lw2-tags-comments
814 (process-votes-result (lw2-graphql-query (lw2-query-string :comment :list (alist :tag-id tag-id :view "tagDiscussionComments") :fields '(:--id :current-user-vote :current-user-extended-vote))
815 :auth-token auth-token))))
817 (define-backend-function get-post-comments (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
818 (backend-graphql
819 (let ((fn (lambda ()
820 (comments-list-to-graphql-json
821 (get-post-comments-list post-id "postCommentsTop")))))
822 (lw2-graphql-query-timeout-cached fn "post-comments-json" post-id :revalidate revalidate :force-revalidate force-revalidate)))
823 (backend-ea-forum
824 ;; Work around bizarre parent comment bug in EA forum
825 (declare (ignore revalidate force-revalidate))
826 (let ((comments (call-next-method)))
827 (dolist (c comments)
828 (if-let (parent-id-cons (assoc :parent-comment-id c))
829 (if (and (string= (cdr parent-id-cons) "rjgZaK8uzHG3jAu2p")
830 (not (string= post-id "h26Kx7uGfQfNewi7d")))
831 (setf (cdr parent-id-cons) nil))))
832 comments)))
834 (defun get-post-answers (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
835 (let ((fn (lambda ()
836 (let ((answers (get-post-comments-list post-id "questionAnswers")))
837 (comments-list-to-graphql-json
838 (nconc
839 answers
840 (get-post-answer-replies post-id answers)))))))
841 (lw2-graphql-query-timeout-cached fn "post-answers-json" post-id :revalidate revalidate :force-revalidate force-revalidate)))
843 (define-backend-function get-collection (collection-id)
844 (backend-graphql
845 (lw2-graphql-query
846 (lw2-query-string :collection :single
847 (alist :document-id collection-id)
848 :fields `(:--id :title (:contents :html) :grid-image-id :----typename
849 (:books :title :subtitle (:contents :html) :----typename
850 (:sequences :title (:contents :html) :grid-image-id :----typename
851 (:chapters :title :subtitle :number (:contents :html) (:posts ,@(request-fields :post :list nil))))))))))
853 (defun sequence-iterate (sequence fn)
854 (dolist (chapter (cdr (assoc :chapters sequence)))
855 (dolist (post (cdr (assoc :posts chapter)))
856 (funcall fn post))))
858 (defun sequence-post-ids (sequence)
859 (with-collector (col)
860 (sequence-iterate sequence
861 (lambda (post)
862 (col (cdr (assoc :--id post)))))
863 (col)))
865 (defun get-sequence-post (sequence post-id)
866 (sequence-iterate sequence
867 (lambda (post)
868 (when (string= (cdr (assoc :--id post)) post-id)
869 (return-from get-sequence-post post))))
870 nil)
872 (define-backend-function get-sequence (sequence-id)
873 (backend-graphql
874 (let ((fn (lambda ()
875 (multiple-value-bind (sequence sequence-json)
876 (lw2-graphql-query
877 (lw2-query-string :sequence :single
878 (alist :document-id sequence-id)
879 :fields `(:--id :title :created-at :user-id
880 (:contents :html)
881 (:chapters :title :subtitle :number (:contents :html) (:posts ,@(request-fields :post :list nil)))
882 :grid-image-id :----typename))
883 :return-type :both)
884 (let ((posts (sequence-post-ids sequence)))
885 (with-cache-transaction
886 (dolist (post-id posts)
887 (let ((old-seqs (cache-get "post-sequence" post-id :value-type :json)))
888 (unless (member sequence-id old-seqs :test #'string=)
889 (cache-put "post-sequence" post-id (cons sequence-id old-seqs) :value-type :json)))))
890 sequence-json)))))
891 (lw2-graphql-query-timeout-cached fn "sequence-json" sequence-id))))
893 (define-backend-function get-post-sequence-ids (post-id)
894 (backend-graphql
895 (cache-get "post-sequence" post-id :value-type :json)))
897 (defun preload-sequences-cache ()
898 (declare (optimize space (compilation-speed 2) (speed 0)))
899 (let ((sequences (apply #'append
900 (loop for view in '("curatedSequences" "communitySequences")
901 collect (lw2-graphql-query (lw2-query-string :sequence :list (alist :view view) :fields '(:--id)))))))
902 (dolist (sequence sequences)
903 (get-sequence (cdr (assoc :--id sequence))))
904 (format t "Retrieved ~A sequences." (length sequences)))
905 (values))
907 (define-backend-function user-deleted (user-id &optional (status nil set))
908 (backend-base
909 (declare (ignore user-id status set))
910 nil)
911 (backend-lw2-modernized
912 (if set
913 (if status
914 (cache-put "user-deleted" user-id "1")
915 (cache-del "user-deleted" user-id))
916 (cache-get "user-deleted" user-id :return-type 'existence))))
918 (define-backend-function get-user (user-identifier-type user-identifier &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
919 (backend-graphql
920 (let* ((user-id (ccase user-identifier-type
921 (:user-id user-identifier)
922 (:user-slug (get-slug-userid user-identifier))))
923 (query-string (lw2-query-string :user :single (alist :document-id user-id) :fields (list-cond* (auth-token :last-notifications-check) (user-fields))))
924 (result (if auth-token
925 (lw2-graphql-query query-string :auth-token auth-token)
926 (lw2-graphql-query-timeout-cached query-string "user-json" user-id :revalidate revalidate :force-revalidate force-revalidate))))
927 (alist-bind ((user-id (or simple-string null) :--id)
928 (display-name (or simple-string null))
929 (full-name (or simple-string null))
930 (slug (or simple-string null))
931 (deleted boolean))
932 result
933 (when user-id
934 (with-cache-transaction
935 (when display-name
936 (cache-username user-id display-name))
937 (when full-name
938 (cache-user-full-name user-id full-name))
939 (when slug
940 (cache-user-slug user-id slug)
941 (cache-slug-userid slug user-id))
942 (user-deleted user-id deleted))))
943 result)))
945 (define-backend-function get-notifications (&key user-id (offset 0) (limit 21) auth-token)
946 (backend-lw2-legacy
947 (lw2-graphql-query (lw2-query-string :notification :list
948 (alist* :user-id user-id :limit limit :offset offset *notifications-base-terms*)
949 :fields '(:--id :document-type :document-id :link :title :message :type :viewed))
950 :auth-token auth-token))
951 (backend-lw2-modernized
952 (declare (ignore user-id offset limit auth-token))
953 (let ((*notifications-base-terms* (remove :null *notifications-base-terms* :key #'cdr)))
954 (call-next-method))))
956 (define-backend-function check-notifications (user-id auth-token &key full since)
957 (backend-lw2-legacy
958 (multiple-value-bind (notifications user-info)
959 (lw2-graphql-query-multi (list
960 (lw2-query-string* :notification :list (alist* :user-id user-id :limit (if full 3 1) *notifications-base-terms*)
961 :fields (if full '(:--id :message :created-at) '(:created-at)))
962 (lw2-query-string* :user :single (alist :document-id user-id) :fields '(:last-notifications-check)))
963 :auth-token auth-token)
964 (let ((last-check (or since
965 (let ((last-check-string (cdr (assoc :last-notifications-check user-info))))
966 (when (and (stringp last-check-string) (not (equal last-check-string "")))
967 (local-time:parse-timestring last-check-string))))))
968 (when notifications
969 (labels ((unread-p (notification)
970 (if last-check
971 (local-time:timestamp>
972 (local-time:parse-timestring (cdr (assoc :created-at notification)))
973 last-check)
974 ;; User has never checked notifications before -- all are unread
975 t)))
976 (if full
977 (remove-if-not #'unread-p notifications)
978 (unread-p (first notifications))))))))
979 (backend-lw2-modernized
980 (declare (ignore user-id auth-token full since))
981 (let ((*notifications-base-terms* (remove :null *notifications-base-terms* :key #'cdr)))
982 (call-next-method))))
984 (define-cache-database 'backend-lw2-legacy "comment-reply-by-user")
986 (define-backend-function mark-comment-replied (reply)
987 (backend-lw2-legacy
988 (alexandria:when-let* ((parent-comment-id (cdr (assoc :parent-comment-id reply)))
989 (reply-id (cdr (assoc :--id reply)))
990 (user-id (cdr (assoc :user-id reply))))
991 (cache-put "comment-reply-by-user" (concatenate 'string parent-comment-id " " user-id) reply-id))))
993 (define-backend-function check-comment-replied (comment-id user-id)
994 (backend-lw2-legacy
995 (cache-get "comment-reply-by-user" (concatenate 'string comment-id " " user-id))))
997 (define-backend-function get-user-page-items (user-id request-type &key (offset 0) (limit 21) (sort-type :date) drafts
998 (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
999 (backend-lw2-legacy
1000 (multiple-value-bind (real-offset real-limit) (if (eq request-type :both)
1001 (values 0 (+ offset limit))
1002 (values offset limit))
1003 (let* ((cache-database (when (and (eq request-type :both)
1004 (or (not offset) (= offset 0))
1005 (= limit 21)
1006 (eq sort-type :date)
1007 (not drafts)
1008 (not auth-token))
1009 "user-page-items"))
1010 (return-type (if cache-database :string nil))
1011 (fn (lambda ()
1012 (labels ((posts-query-string ()
1013 (let* ((base-terms
1014 (cond
1015 (drafts (alist :view "drafts"))
1016 ((eq sort-type :score) (alist :view "top"))
1017 ((eq sort-type :date-reverse) (alist :view "old"))
1018 (t (alist :view "userPosts"))))
1019 (terms (alist* :offset real-offset :limit real-limit :user-id user-id base-terms)))
1020 (declare (dynamic-extent base-terms terms))
1021 (lw2-query-string* :post :list terms)))
1022 (comments-query-string ()
1023 (let* ((view (ecase sort-type
1024 (:score "postCommentsTop")
1025 (:date "allRecentComments")
1026 (:date-reverse "postCommentsOld")))
1027 (terms (alist :offset real-offset
1028 :limit real-limit
1029 :user-id user-id
1030 :view view)))
1031 (declare (dynamic-extent view terms))
1032 (lw2-query-string* :comment :list terms
1033 :context :index))))
1034 (declare (dynamic-extent #'posts-query-string #'comments-query-string))
1035 (case request-type
1036 (:both (let ((result (multiple-value-call #'concatenate 'list
1037 (lw2-graphql-query-multi (list (posts-query-string) (comments-query-string))))))
1038 (ecase return-type
1039 (:string (json:encode-json-to-string result))
1040 ((nil) result))))
1041 (:posts (lw2-graphql-query (format nil "{~A}" (posts-query-string)) :auth-token auth-token :return-type return-type))
1042 (:comments (lw2-graphql-query (format nil "{~A}" (comments-query-string)) :auth-token auth-token :return-type return-type)))))))
1043 (if cache-database
1044 (lw2-graphql-query-timeout-cached fn cache-database user-id :decoder 'deserialize-query-result :revalidate revalidate :force-revalidate force-revalidate)
1045 (funcall fn))))))
1047 (define-backend-function get-conversation-messages (conversation-id auth-token)
1048 (backend-lw2-legacy
1049 (lw2-graphql-query-multi
1050 (list
1051 (lw2-query-string* :conversation :single (alist :document-id conversation-id) :fields '(:title (:participants :display-name :slug)))
1052 (lw2-query-string* :message :list (alist :view "messagesConversation" :conversation-id conversation-id) :fields *messages-index-fields*))
1053 :auth-token auth-token)))
1055 (define-backend-function lw2-search-query (query &key (indexes '("test_tags" "test_posts" "test_comments")))
1056 (backend-algolia-search
1057 (call-with-http-response
1058 (lambda (req-stream)
1059 (values-list (loop for r in (cdr (assoc :results (json:decode-json req-stream)))
1060 collect (cdr (assoc :hits r)))))
1061 (algolia-search-uri *current-backend*)
1062 :method :post
1063 :headers '(("Origin" . "https://www.greaterwrong.com")
1064 ("Referer" . "https://www.greaterwrong.com/")
1065 ("Content-Type" . "application/json"))
1066 :content (json:encode-json-alist-to-string
1067 (alist "requests" (loop for index in indexes
1068 collect (alist "indexName" index
1069 "params" (format nil "query=~A&hitsPerPage=20&page=0"
1070 (url-rewrite:url-encode query))))))
1071 :want-stream t)))
1073 (define-backend-function get-username-wrapper (user-id fn)
1074 (backend-base
1075 (funcall fn user-id))
1076 (backend-lw2-modernized
1077 (if (user-deleted user-id)
1078 "[deleted]"
1079 (funcall fn user-id))))
1081 (define-cache-database 'backend-lw2-legacy "comment-markdown-source" "post-markdown-source")
1083 (defun markdown-source-db-name (target-type)
1084 (ecase target-type (:comment "comment-markdown-source") (:post "post-markdown-source")))
1086 (define-backend-function markdown-source (target-type id version)
1087 (backend-lw2-modernized
1088 (let ((db-name (markdown-source-db-name target-type))
1089 (version (base64:usb8-array-to-base64-string (hash-string version))))
1091 (if-let ((cache-data (cache-get db-name id :value-type :lisp)))
1092 (alist-bind ((cached-version simple-string :version)
1093 (markdown simple-string))
1094 cache-data
1095 (when (string= version cached-version)
1096 markdown)))
1097 (trivia:ematch (lw2-graphql-query (lw2-query-string target-type :single
1098 (alist :document-id id)
1099 :fields '(:html-body (:contents :markdown)))
1100 :auth-token *current-auth-token*)
1101 ((trivia:alist (:html-body . html-body)
1102 (:contents . (assoc :markdown markdown)))
1103 (cache-put db-name id (alist :version (base64:usb8-array-to-base64-string (hash-string html-body)) :markdown markdown) :value-type :lisp)
1104 markdown))))))
1106 (define-backend-function (setf markdown-source) (markdown target-type id version)
1107 (backend-lw2-modernized
1108 (let ((version (base64:usb8-array-to-base64-string (hash-string version))))
1109 (cache-put (markdown-source-db-name target-type)
1111 (alist :version version :markdown markdown)
1112 :value-type :lisp))))
1114 (defun get-elicit-question-title (question-id)
1115 (cdr
1116 (lw2-graphql-query (graphql-query-string "ElicitBlockData" (alist :question-id question-id) '(:title)))))
1118 (defun make-rate-limiter (delay)
1119 (let ((rl-hash (make-hash-table :test 'equal :synchronized t)))
1120 (lambda (datum fn)
1121 (let ((unix-time (get-unix-time)))
1122 (if (sb-ext:with-locked-hash-table (rl-hash)
1123 (maphash (lambda (k v)
1124 (if (> (- unix-time v) delay)
1125 (remhash k rl-hash)))
1126 rl-hash)
1127 (not (gethash datum rl-hash)))
1128 (progn
1129 (setf (gethash datum rl-hash) unix-time)
1130 (funcall fn))
1131 (error "Request aborted due to rate limit."))))))
1133 (defmacro with-rate-limit (&body outer-body)
1134 `(let ((rate-limiter (make-rate-limiter 30)))
1135 (macrolet ((rate-limit ((key) &body inner-body)
1136 `(funcall rate-limiter ,key (lambda () ,@inner-body))))
1137 ,@outer-body)))
1139 (with-rate-limit
1140 (simple-cacheable ("post-title" 'backend-lw2-legacy "postid-to-title" post-id)
1141 (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) :fields '(:title))))))))
1143 (with-rate-limit
1144 (simple-cacheable ("post-slug" 'backend-lw2-legacy "postid-to-slug" post-id)
1145 (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) :fields '(:slug))))))))
1147 (with-rate-limit
1148 (simple-cacheable ("slug-postid" 'backend-lw2-legacy "slug-to-postid" slug)
1149 (rate-limit (slug) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :slug slug) :fields '(:--id))))))))
1151 (with-rate-limit
1152 (simple-cacheable ("username" 'backend-lw2-legacy "userid-to-displayname" user-id :get-wrapper #'get-username-wrapper)
1153 (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) :fields '(:display-name))))))))
1155 (with-rate-limit
1156 (simple-cacheable ("user-slug" 'backend-lw2-legacy "userid-to-slug" user-id)
1157 (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) :fields '(:slug))))))))
1159 (with-rate-limit
1160 (simple-cacheable ("user-full-name" 'backend-lw2-legacy "userid-to-full-name" user-id)
1161 (rate-limit (user-id) (or (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) :fields '(:full-name)))))
1162 ""))))
1164 (with-rate-limit
1165 (simple-cacheable ("slug-userid" 'backend-lw2-legacy "slug-to-userid" slug)
1166 (rate-limit (slug) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :slug slug) :fields '(:--id))))))))
1168 (with-rate-limit
1169 (simple-cacheable ("slug-tagid" 'backend-lw2-tags "slug-to-tagid" slug :catch-errors nil)
1170 (rate-limit (slug) (cdr (first (first (lw2-graphql-query (lw2-query-string :tag :list (alist :view "tagBySlug" :slug slug) :fields '(:--id)))))))))
1172 (defun preload-username-cache ()
1173 (declare (optimize space (compilation-speed 2) (speed 0)))
1174 (let ((user-list (lw2-graphql-query (lw2-query-string :user :list '() :fields '(:--id :slug :display-name)))))
1175 (with-cache-transaction
1176 (loop for user in user-list
1177 do (alist-bind ((user-id (or simple-string null) :--id)
1178 (slug (or simple-string null))
1179 (display-name (or simple-string null)))
1180 user
1181 (when user-id
1182 (when display-name
1183 (cache-username user-id display-name))
1184 (when slug
1185 (cache-user-slug user-id slug)
1186 (cache-slug-userid slug user-id))))))))