Speed up MathJax processing by reusing the node process.
[lw2-viewer.git] / src / backend.lisp
blobf16942202c1ab52f0def5cb1488295252cc3bb71
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 #:start-background-loader #:stop-background-loader #:background-loader-running-p
13 #:call-with-http-response
14 #:forwarded-header #:backend-request-headers
15 #:lw2-graphql-query #:lw2-query-string* #:lw2-query-string
16 #:lw2-graphql-query-map #:lw2-graphql-query-multi
17 #:signal-lw2-errors
18 #:earliest-post-time
19 #:flatten-shortform-comments #:get-shortform-votes
20 #:get-tag-posts
21 #:get-post-tag-votes #:get-tag-post-votes
22 #:get-slug-tagid
23 #:get-posts-index #:get-posts-json #:get-post-body #:get-post-vote #:get-post-comments #:get-post-answers
24 #:get-post-comments-votes
25 #:get-tag-comments-votes
26 #:get-recent-comments #:get-recent-comments-json
27 #:sequence-post-ids #:get-sequence #:get-post-sequence-ids #:get-sequence-post
28 #:get-conversation-messages
29 #:markdown-source
30 #:get-user
31 #:get-notifications #:check-notifications
32 #:mark-comment-replied #:check-comment-replied
33 #:lw2-search-query #:get-post-title #:get-post-slug #:get-slug-postid #:get-username #:get-user-full-name #:get-user-slug
34 #:do-wl-rest-mutate #:do-wl-rest-query #:do-wl-create-tag)
35 (:recycle #:lw2-viewer)
36 (:unintern #:get-posts #:make-posts-list-query #:define-backend-fields
37 #:*posts-index-fields* #:posts-index-fields #:post-body-fields
38 #:*comments-index-fields* #:comments-index-fields
39 #:*post-comments-fields* #:post-comments-fields
40 #:define-index-fields #:decode-graphql-json
41 #:lw2-graphql-query-noparse #:lw2-graphql-query-streamparse
42 #:*cookie-jar*
43 #:with-connection-pool #:call-with-connection-pool))
45 (in-package #:lw2.backend)
47 ;; Dexador settings required for the system to work properly.
48 (setf dex:*default-connect-timeout* nil
49 dex:*default-read-timeout* nil
50 dex:*use-connection-pool* nil)
52 (defvar *use-alignment-forum* nil)
54 (defvar *graphql-debug-output* nil)
56 (defvar *revalidate-default* t)
57 (defvar *force-revalidate-default* nil)
59 (defparameter *messages-index-fields* '(:--id :user-id :created-at (:contents :html) (:conversation :--id :title) :----typename))
60 (defparameter *user-fields* '(:--id :slug :display-name :karma))
62 (defparameter *notifications-base-terms* (alist :view "userNotifications" :created-at :null :viewed :null))
64 (defun request-fields (query-type return-type context)
65 "Returns the desired fields for a given type of request."
66 (case return-type
67 (:total nil)
69 (with-collector (col)
70 (let ((backend *current-backend*)
71 (schema-type (find-schema-type query-type))
72 (added (make-hash-table :test 'eq)))
73 (dolist (field (cdr (assoc :fields schema-type)) (col))
74 (destructuring-bind (field-name field-type &key alias backend-type graphql-ignore subfields ((:context field-context)) context-not &allow-other-keys) field
75 (declare (ignore field-type))
76 (when (and (not (gethash field-name added))
77 (not graphql-ignore)
78 (or (not backend-type) (typep backend backend-type))
79 (or (not field-context) (eq context field-context))
80 (or (not context-not) (not (eq context context-not))))
81 (setf (gethash field-name added) t)
82 (col
83 (let ((result-name (or alias field-name)))
84 (if subfields
85 (list* result-name subfields)
86 result-name)))))))))))
88 (define-backend-function user-fields ()
89 (backend-lw2-legacy (load-time-value *user-fields*))
90 (backend-lw2-modernized (append (call-next-method) '(:groups :deleted :html-bio)))
91 (backend-alignment-forum (append (call-next-method) '(:af-karma :full-name))))
93 (define-cache-database 'backend-lw2-legacy
94 "index-json"
95 "post-comments-json" "post-comments-json-meta" "post-answers-json" "post-answers-json-meta"
96 "post-body-json" "post-body-json-meta"
97 "sequence-json" "sequence-json-meta" "post-sequence"
98 "user-json" "user-json-meta"
99 "user-page-items" "user-page-items-meta")
101 (define-cache-database 'backend-lw2-modernized
102 "user-deleted")
104 (define-backend-function comments-list-to-graphql-json (comments-list)
105 (backend-lw2-legacy
106 (json:encode-json-to-string
107 (plist-hash-table (list :data (plist-hash-table (list :*comments-list comments-list))))))
108 (backend-lw2-modernized
109 (json:encode-json-to-string
110 (plist-hash-table (list :data (plist-hash-table (list :*comments-list (plist-hash-table (list :results comments-list)))))))))
112 (defun do-graphql-debug (query)
113 (when *graphql-debug-output*
114 (format *graphql-debug-output* "~&GraphQL query: ~A~%" query)))
116 (defmacro with-retrying ((maybe-retry-fn-name &key retries before-maybe-retry before-retry) &body body)
117 (with-gensyms (remaining-retries retry)
118 `(let ((,remaining-retries ,retries))
119 (tagbody ,retry
120 (labels ((,maybe-retry-fn-name ()
121 ,before-maybe-retry
122 (when (> ,remaining-retries 0)
123 (decf ,remaining-retries)
124 ,before-retry
125 (go ,retry))))
126 ,@body)))))
128 (defun force-close (stream)
129 (ignore-errors (close stream :abort t)))
131 (sb-ext:defglobal *connection-pool* (make-hash-table :test 'equal))
132 (sb-ext:defglobal *connection-pool-lock* (sb-thread:make-mutex :name "*connection-pool-lock*"))
134 (defun connection-push (dest connection)
135 (let ((connection-pool *connection-pool*)
136 old-connection)
137 (sb-thread:with-mutex (*connection-pool-lock*)
138 (let ((vector (or (gethash dest connection-pool)
139 (setf (gethash dest connection-pool)
140 (make-array 4 :fill-pointer 0)))))
141 (unless (vector-push connection vector)
142 (setf old-connection (vector-pop vector))
143 (vector-push connection vector))))
144 (when old-connection
145 (force-close old-connection))))
147 (defun connection-pop (dest)
148 (let ((connection-pool *connection-pool*))
149 (sb-thread:with-mutex (*connection-pool-lock*)
150 (when-let (vector (gethash dest connection-pool))
151 (when (> (fill-pointer vector) 0)
152 (vector-pop vector))))))
154 (defun call-with-http-response (fn uri-string &rest args &key &allow-other-keys)
155 (let* ((uri (quri:uri uri-string))
156 (uri-dest (concatenate 'string (quri:uri-host uri) ":" (format nil "~d" (quri:uri-port uri))))
157 (stream (connection-pop uri-dest)))
158 (let (response status-code headers response-uri new-stream success)
159 (with-retrying (maybe-retry :retries 3
160 :before-retry (sleep 0.2))
161 (unwind-protect
162 (handler-bind (((or dex:http-request-failed usocket:ns-condition usocket:socket-condition)
163 (lambda (condition)
164 (if-let ((r (find-restart 'dex:ignore-and-continue condition)))
165 (invoke-restart r)
166 (maybe-retry)))))
167 (setf (values response status-code headers response-uri new-stream)
168 (apply 'dex:request uri :use-connection-pool nil :keep-alive t :stream stream args))
169 (unless (eq stream new-stream)
170 (when stream (force-close stream))
171 (setf stream new-stream
172 new-stream nil))
173 (when (<= 500 status-code 599)
174 (maybe-retry)
175 (error 'lw2-connection-error :message (format nil "HTTP status ~A" status-code)))
176 (setf success t))
177 (when (not success)
178 (when (streamp response)
179 (force-close response))
180 (when stream
181 (force-close stream))
182 (setf stream nil))))
183 (unwind-protect
184 (funcall fn response)
185 (when (streamp response)
186 (close response))
187 (when stream ; the connection is reusable
188 (connection-push uri-dest stream))))))
190 (defun forwarded-header ()
191 (let ((addr (and (boundp 'hunchentoot:*request*) (hunchentoot:real-remote-addr))))
192 (list-cond (addr "X-Forwarded-For" addr))))
194 (defun signal-lw2-errors (errors)
195 (loop for error in errors
196 do (let ((message (cdr (assoc :message error)))
197 (path (cdr (assoc :path error))))
198 (unless (and path (> (length path) 1))
199 (cond
200 ((search "document_not_found" message) (error 'lw2-not-found-error))
201 ((search "app.missing_document" message) (error 'lw2-not-found-error))
202 ((search "only visible to logged-in users" message) (error 'lw2-login-required-error))
203 ((search "not_allowed" message) (error 'lw2-not-allowed-error))
204 (t (error 'lw2-unknown-error :message message)))))))
206 (define-backend-function earliest-post-time ()
207 (backend-lw2 (load-time-value (local-time:parse-timestring "2005-01-01")))
208 (backend-ea-forum (load-time-value (local-time:parse-timestring "2011-11-24"))))
210 (define-backend-function fixup-lw2-return-value (value)
211 (backend-base
212 value)
213 (backend-lw2-modernized
214 (values-list
215 (map 'list
216 (lambda (x)
217 (if (member (car x) '(:result :results :total-count))
218 (cdr x)
220 value)))
221 (backend-accordius
222 value))
224 (define-backend-function deserialize-query-result (result-source)
225 (backend-base
226 (let ((string-source (typecase result-source
227 (string
228 result-source)
229 (vector
230 (flexi-streams:make-in-memory-input-stream result-source))
231 (stream
232 (ensure-character-stream result-source)))))
233 (json:decode-json-from-source string-source))))
235 (define-backend-function postprocess-query-result (result)
236 (backend-base
237 result)
238 (backend-lw2-legacy
239 (signal-lw2-errors (cdr (assoc :errors result)))
240 (fixup-lw2-return-value (cdadr (assoc :data result)))))
242 (define-backend-function decode-query-result (result-source)
243 (backend-base
244 (postprocess-query-result
245 (deserialize-query-result result-source))))
247 (defmethod graphql-uri ((backend backend-alignment-forum))
248 (if *use-alignment-forum*
249 "https://www.alignmentforum.org/graphql"
250 (call-next-method)))
252 (define-backend-function backend-request-headers (auth-token forwarded)
253 (backend-websocket-login
254 (list-cond* (auth-token :authorization auth-token)
255 (call-next-method)))
256 (backend-passport-js-login
257 (list-cond* (auth-token :cookie (concatenate 'string "loginToken=" auth-token))
258 (call-next-method)))
259 (backend-graphql
260 (alist* :content-type "application/json"
261 (if forwarded (forwarded-header)))))
263 (define-backend-function call-with-backend-response (fn query &key return-type auth-token)
264 (backend-graphql
265 (call-with-http-response
267 (graphql-uri *current-backend*)
268 :method :post
269 :headers (backend-request-headers auth-token nil)
270 :content (dynamic-let ((q (alist :query query))) (json:encode-json-to-string q))
271 :want-stream (not return-type))))
273 (define-backend-function lw2-graphql-query (query &key auth-token return-type (decoder 'decode-query-result))
274 (backend-base
275 (do-graphql-debug query)
276 (call-with-backend-response
277 (ecase return-type
278 ((nil) decoder)
279 (:string #'identity)
280 (:both (lambda (string) (values (funcall decoder string) string))))
281 query
282 :return-type return-type
283 :auth-token auth-token)))
285 (defun lw2-graphql-query-map (fn data &key auth-token postprocess)
286 (multiple-value-bind (map-values queries)
287 (loop for d in data
288 as out-values = (multiple-value-list (funcall fn d))
289 as (out passthrough-p) = out-values
290 collect out-values into map-values
291 when (not passthrough-p) collect out into queries
292 finally (return (values map-values queries)))
293 (let* ((query-string
294 (with-output-to-string (stream)
295 (format stream "{")
296 (loop for n from 0
297 for q in queries
298 do (format stream "g~6,'0D:~A " n q))
299 (format stream "}")))
300 (query-result-data (when queries (lw2-graphql-query query-string :decoder 'deserialize-query-result :auth-token auth-token)))
301 (errors (cdr (assoc :errors query-result-data))))
302 (signal-lw2-errors errors)
303 (values
304 (loop as results = (sort (cdr (assoc :data query-result-data)) #'string< :key #'car) then (if passthrough-p results (rest results))
305 for (out passthrough-p) in map-values
306 as result-data-cell = (first results)
307 as result-data = (if passthrough-p out (fixup-lw2-return-value (cdr result-data-cell)))
308 for input-data in data
309 collect (if postprocess (funcall postprocess input-data result-data) result-data))
310 errors))))
312 (defun lw2-graphql-query-multi (query-list &key auth-token)
313 (values-list (lw2-graphql-query-map #'identity query-list :auth-token auth-token)))
315 (defvar *background-cache-update-threads* (make-hash-table :test 'equal
316 :weakness :value
317 :synchronized t))
319 (defun cache-update (cache-db key data)
320 (let ((meta-db (format nil "~A-meta" cache-db))
321 (new-hash (hash-string data))
322 (current-time (get-unix-time)))
323 (with-cache-transaction
324 (let* ((metadata (cache-get meta-db key :value-type :lisp))
325 (last-mod (if (equalp new-hash (cdr (assoc :city-128-hash metadata)))
326 (or (cdr (assoc :last-modified metadata)) current-time)
327 current-time)))
328 (cache-put meta-db key (alist :last-checked current-time :last-modified last-mod :city-128-hash new-hash) :value-type :lisp)
329 (cache-put cache-db key data)))))
331 (defun cache-mark-stale (cache-db key)
332 (let ((meta-db (format nil "~A-meta" cache-db))
333 (current-time (get-unix-time)))
334 (with-cache-transaction
335 (let* ((metadata (cache-get meta-db key :value-type :lisp))
336 (metadata (alist* :last-modified current-time (delete :last-modified metadata :key #'car))))
337 (cache-put meta-db key metadata :value-type :lisp)))))
339 (declaim (type (and fixnum (integer 1)) *cache-stale-factor* *cache-skip-factor*))
340 (defparameter *cache-stale-factor* 100)
341 (defparameter *cache-skip-factor* 5000)
343 (defun cache-is-fresh (cache-db key)
344 (let ((metadata (cache-get (format nil "~A-meta" cache-db) key :value-type :lisp))
345 (current-time (get-unix-time)))
346 (if-let ((last-mod (cdr (assoc :last-modified metadata)))
347 (last-checked (cdr (assoc :last-checked metadata))))
348 (let ((unmodified-time (- last-checked last-mod))
349 (last-checked-time (- current-time last-checked)))
350 (if (> unmodified-time (* *cache-skip-factor* last-checked-time))
351 :skip
352 (> unmodified-time (* *cache-stale-factor* last-checked-time)))))))
354 (defgeneric run-query (query)
355 (:method ((query string))
356 (lw2-graphql-query query :return-type :string))
357 (:method ((query function))
358 (funcall query)))
360 (declaim (inline make-thread-with-current-backend))
362 (defun make-thread-with-current-backend (fn &rest args)
363 (let ((current-backend *current-backend*))
364 (apply #'sb-thread:make-thread
365 (lambda ()
366 (let ((*current-backend* current-backend))
367 (funcall fn)))
368 args)))
370 (defun ensure-cache-update-thread (query cache-db cache-key)
371 (let ((key (format nil "~A-~A" cache-db cache-key)))
372 (labels ((background-fn ()
373 (unwind-protect
374 (multiple-value-bind (value error)
375 (log-and-ignore-errors
376 (sb-sys:with-deadline (:seconds 60)
377 (nth-value 0
378 (cache-update cache-db cache-key (run-query query)))))
379 (or value error))
380 (remhash key *background-cache-update-threads*))))
381 (sb-ext:with-locked-hash-table (*background-cache-update-threads*)
382 (let ((thread (gethash key *background-cache-update-threads*)))
383 (if thread thread
384 (setf (gethash key *background-cache-update-threads*)
385 (make-thread-with-current-backend #'background-fn :name "background cache update"))))))))
387 (define-backend-function lw2-graphql-query-timeout-cached (query cache-db cache-key &key (decoder 'decode-query-result)
388 (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
389 (backend-base
390 (multiple-value-bind (cached-result is-fresh) (with-cache-readonly-transaction
391 (values (cache-exists cache-db cache-key)
392 (cache-is-fresh cache-db cache-key)))
393 (labels ((get-cached-result ()
394 (with-cache-readonly-transaction (funcall decoder (cache-get cache-db cache-key :return-type 'binary-stream)))))
395 (if (and cached-result (or (not revalidate)
396 (and (not force-revalidate) (eq is-fresh :skip))))
397 (get-cached-result)
398 (let ((timeout (if cached-result
399 (if force-revalidate nil 3)
400 nil))
401 (thread (ensure-cache-update-thread query cache-db cache-key)))
402 (block retrieve-result
403 (if (and cached-result (if force-revalidate (not revalidate) (or is-fresh (not revalidate))))
404 (get-cached-result)
405 (handler-bind
406 ((fatal-error (lambda (c)
407 (declare (ignore c))
408 (if cached-result
409 (return-from retrieve-result (get-cached-result))))))
410 (let ((new-result (sb-thread:join-thread thread :timeout timeout)))
411 (typecase new-result
412 (condition (error new-result))
413 (t (funcall decoder new-result)))))))))))))
415 (define-backend-function lw2-query-string* (query-type return-type args &key context fields with-total))
417 (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)
418 (declare (ignore with-total))
419 (labels ((lisp-to-lw2-case (x) (json:lisp-to-camel-case (format nil "*~A" x))))
420 (graphql-query-string*
421 (concatenate 'string
422 (lisp-to-lw2-case query-type)
424 (lisp-to-lw2-case return-type))
425 (if (eq return-type :single)
426 args
427 (alist :terms args))
428 fields)))
430 (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)
431 (graphql-query-string*
432 (if (eq return-type :single)
433 (json:lisp-to-camel-case (string query-type))
434 (concatenate 'string (json:lisp-to-camel-case (string query-type)) "s"))
435 (alist :input (case return-type
436 (:single (alist :selector args))
437 (:list (alist :enable-total with-total :terms args))
438 (:total (alist :enable-total t :terms args))))
439 (case return-type
440 (:total '(:total-count))
441 (:list (list-cond (t :results fields)
442 (with-total :total-count)))
443 (:single (alist :result fields)))))
445 (define-backend-function lw2-query-string (query-type return-type args &key context fields with-total))
447 (define-backend-operation lw2-query-string backend-lw2-legacy (query-type return-type args &rest rest &key context fields with-total)
448 (declare (ignore context fields with-total))
449 (format nil "{~A}" (apply 'lw2-query-string* query-type return-type args rest)))
451 (define-backend-function lw2-query-list-limit-workaround (query-type terms &rest rest &key fields context auth-token)
452 (backend-graphql
453 (declare (ignore fields context))
454 (let (items-list)
455 (loop for offset from 0 by 500
456 as items-next = (lw2-graphql-query (apply 'lw2-query-string query-type :list (alist* :limit 500 :offset offset terms) (filter-plist rest :fields :context))
457 :auth-token auth-token)
458 as length = (length items-next)
459 do (setf items-list (nconc items-list items-next))
460 while (>= length 500))
461 items-list))
462 (backend-accordius
463 (declare (ignore fields context))
464 (lw2-graphql-query (apply 'lw2-query-string query-type :list terms (filter-plist rest :fields :context)) :auth-token auth-token)))
466 (defun get-cached-index-query (cache-id query)
467 (labels ((query-and-put ()
468 (let* ((result (lw2-graphql-query query :return-type :string))
469 (decoded-result (multiple-value-list (decode-query-result result))))
470 (cache-put "index-json" cache-id result)
471 (values-list decoded-result)))
472 (get-cached-result ()
473 (with-cache-readonly-transaction (decode-query-result (cache-get "index-json" cache-id :return-type 'binary-stream)))))
474 (let ((cached-result (cache-get "index-json" cache-id :return-type 'existence)))
475 (if (and cached-result (background-loader-ready-p))
476 (get-cached-result)
477 (if cached-result
478 (handler-case
479 (query-and-put)
480 (t () (get-cached-result)))
481 (query-and-put))))))
483 (define-backend-function get-posts-index-query-terms (&key view (sort "new") (limit 21) offset before after &allow-other-keys)
484 (backend-lw2-legacy
485 (let ((sort-key (alexandria:switch (sort :test #'string=)
486 ("new" "new")
487 ("hot" "magic")
488 ("active" "recentComments")
489 ("top" "top")
490 ("old" "old"))))
491 (multiple-value-bind (view-terms cache-key)
492 (alexandria:switch (view :test #'string=)
493 ("featured" (alist :sorted-by sort-key :filter "curated"))
494 ("all" (alist :sorted-by sort-key :filter "all"))
495 ("alignment-forum" (alist :sorted-by sort-key :af t))
496 ("questions" (alist :sorted-by sort-key :filter "questions"))
497 ("events" (alist :sorted-by sort-key :filter "events"))
498 ("nominations" (alist :view "nominations2019"))
499 ("reviews" (alist :view "reviews2019"))
500 (t (values
501 (alist :sorted-by sort-key :filter "frontpage")
502 (if (not (or (string/= sort "new") (/= limit 21) offset before after)) "new-not-meta"))))
503 (let ((terms
504 (alist-without-null* :before before
505 :after after
506 :limit limit
507 :offset offset
508 view-terms)))
509 (values terms cache-key))))))
511 (define-backend-operation get-posts-index-query-terms backend-lw2-tags :around (&key hide-tags &allow-other-keys)
512 (multiple-value-bind (query-terms cache-key) (call-next-method)
513 (if hide-tags
514 (values (acons :filter-settings (alist :tags (list* :list (map 'list (lambda (tagid) (alist :tag-id tagid :filter-mode "Hidden"))
515 hide-tags)))
516 query-terms)
517 nil)
518 (values query-terms cache-key))))
520 (define-backend-function get-posts-index-query-string (&rest args &key &allow-other-keys)
521 (backend-lw2-legacy
522 (declare (dynamic-extent args))
523 (multiple-value-bind (query-terms cache-key)
524 (apply #'%get-posts-index-query-terms backend args)
525 (values (lw2-query-string :post :list query-terms)
526 cache-key))))
528 (define-backend-function get-posts-index (&rest args &key &allow-other-keys)
529 (backend-lw2-legacy
530 (declare (dynamic-extent args))
531 (multiple-value-bind (query-string cache-key)
532 (apply #'%get-posts-index-query-string backend args)
533 (if cache-key
534 (get-cached-index-query cache-key query-string)
535 (lw2-graphql-query query-string)))))
537 (define-backend-operation get-posts-index backend-lw2-tags :around (&rest args &key hide-tags offset (limit 21) &allow-other-keys)
538 ;; Workaround for https://github.com/LessWrong2/Lesswrong2/issues/3099
539 (declare (dynamic-extent args))
540 (if hide-tags
541 (let ((offset (or offset 0)))
542 (subseq
543 (apply #'call-next-method backend :offset 0 :limit (+ limit offset) args)
544 offset))
545 (call-next-method)))
547 (defun get-posts-json ()
548 (lw2-graphql-query (get-posts-index-query-string) :return-type :string))
550 (defun get-recent-comments (&key with-total)
551 (get-cached-index-query "recent-comments" (lw2-query-string :comment :list '((:view . "allRecentComments") (:limit . 20)) :context :index :with-total with-total)))
553 (defun get-recent-comments-json ()
554 (lw2-graphql-query (lw2-query-string :comment :list '((:view . "allRecentComments") (:limit . 20)) :context :index) :return-type :string))
556 (defun process-vote-result (res)
557 (alist-bind ((id (or null simple-string) :--id)
558 current-user-votes
559 current-user-vote
560 current-user-extended-vote)
562 (let ((karma-vote (or (nonempty-string current-user-vote)
563 (cdr (assoc :vote-type (first current-user-votes))))))
564 (values (list-cond* (karma-vote :karma karma-vote)
565 current-user-extended-vote)
566 id))))
568 (defun process-votes-result (res)
569 (let ((hash (make-hash-table)))
570 (dolist (v res hash)
571 (multiple-value-bind (vote id) (process-vote-result v)
572 (when vote
573 (setf (gethash id hash) vote))))))
575 (defun flatten-shortform-comments (comments)
576 (let ((output comments))
577 (loop for comment in comments do
578 (setf output (append (cdr (assoc :latest-children comment)) output)))
579 output))
581 (defun get-shortform-votes (auth-token &key (offset 0) (limit 20))
582 (process-votes-result
583 (flatten-shortform-comments
584 (lw2-graphql-query (lw2-query-string :comment :list (alist :view "shortform" :offset offset :limit limit)
585 :fields '(:--id :current-user-vote :current-user-extended-vote (:latest-children :--id :current-user-vote :current-user-extended-vote)))
586 :auth-token auth-token))))
588 (defun get-post-vote (post-id auth-token)
589 (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)))
591 (define-cache-database 'backend-lw2-tags "tag-posts" "tag-posts-meta" "post-tags" "post-tags-meta")
593 (define-backend-function get-tag-posts (slug &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
594 (backend-base (declare (ignore revalidate force-revalidate)) nil)
595 (backend-lw2-tags
596 (let* ((tagid (get-slug-tagid slug))
597 (query-fn (lambda ()
598 (comments-list-to-graphql-json
599 (lw2-query-list-limit-workaround
600 :tag-rel
601 (alist :view "postsWithTag" :tag-id tagid)
602 :fields (list (list* :post (request-fields :post :list :index))))))))
603 (iter
604 (for x in (lw2-graphql-query-timeout-cached query-fn "tag-posts" tagid :revalidate revalidate :force-revalidate force-revalidate))
605 (when-let (post (cdr (assoc :post x)))
606 (collect post))))))
608 (define-backend-function get-tag-post-votes (tag-id auth-token)
609 (backend-base (progn tag-id auth-token nil))
610 (backend-lw2-tags
611 (process-votes-result
612 (map 'list #'cdr
613 (lw2-query-list-limit-workaround
614 :tag-rel
615 (alist :view "postsWithTag" :tag-id tag-id)
616 :fields '(:--id :current-user-vote :current-user-extended-vote)
617 :auth-token auth-token)))))
619 (define-backend-function get-post-tags (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
620 (backend-base (declare (ignore revalidate force-revalidate)) nil)
621 (backend-lw2-tags
622 (let ((query-string (lw2-query-string :tag-rel :list (alist :view "tagsOnPost" :post-id post-id) :fields '((:tag :name :slug)))))
623 (lw2-graphql-query-timeout-cached query-string "post-tags" post-id :revalidate revalidate :force-revalidate force-revalidate))))
625 (define-backend-function get-post-tag-votes (post-id auth-token)
626 (backend-base (progn post-id auth-token nil))
627 (backend-lw2-tags
628 (process-votes-result
629 (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))
630 :auth-token auth-token))))
632 (define-backend-function get-post-body (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
633 (backend-graphql
634 (let ((query-string (lw2-query-string :post :single (alist :document-id post-id) :context :body)))
635 (block nil
636 (tagbody retry
637 (handler-bind ((lw2-login-required-error (lambda (&rest args)
638 (declare (ignore args))
639 (let ((current-auth-token *current-auth-token*))
640 (when (and (not auth-token) current-auth-token)
641 (setf auth-token current-auth-token)
642 (go retry))))))
643 (return
644 (if auth-token
645 (lw2-graphql-query query-string :auth-token auth-token)
646 (lw2-graphql-query-timeout-cached query-string "post-body-json" post-id :revalidate revalidate :force-revalidate force-revalidate))))))))
647 (backend-lw2-tags
648 (declare (ignore auth-token))
649 (acons :tags (get-post-tags post-id :revalidate revalidate :force-revalidate force-revalidate) (call-next-method))))
651 (defun get-post-comments-list (post-id view &rest rest &key auth-token parent-answer-id fields context)
652 (declare (ignore fields context auth-token))
653 (let ((terms (alist :view view :post-id post-id)))
654 (when parent-answer-id
655 (setf terms (acons :parent-answer-id parent-answer-id terms)))
656 (apply 'lw2-query-list-limit-workaround :comment terms (filter-plist rest :fields :context :auth-token))))
658 (defun get-post-answer-replies (post-id answers &rest rest &key auth-token fields context)
659 ;; todo: support more than 500 answers per question
660 (declare (ignore fields context))
661 (let* ((terms (alist :view "repliesToAnswer" :post-id post-id :limit 500))
662 (result (lw2-graphql-query-map
663 #'identity
664 (mapcar (lambda (answer) (apply 'lw2-query-string* :comment :list
665 (acons :parent-answer-id (cdr (assoc :--id answer)) terms)
666 (filter-plist rest :fields :context)))
667 answers)
668 :auth-token auth-token)))
669 (apply #'nconc result)))
671 (define-backend-function get-post-comments-votes (post-id auth-token)
672 (backend-graphql
673 (let ((fields '(:--id :current-user-vote :current-user-extended-vote)))
674 (process-votes-result
675 (get-post-comments-list post-id "postCommentsTop" :auth-token auth-token :fields fields))))
676 (backend-q-and-a
677 (let* ((fields '(:--id :current-user-vote :current-user-extended-vote))
678 (answers (get-post-comments-list post-id "questionAnswers" :auth-token auth-token :fields fields)))
679 (process-votes-result
680 (nconc
681 (get-post-comments-list post-id "postCommentsTop" :auth-token auth-token :fields fields)
682 (get-post-answer-replies post-id answers :auth-token auth-token :fields fields)
683 answers)))))
685 (define-backend-function get-tag-comments-votes (tag-id auth-token)
686 (backend-lw2-tags-comments
687 (process-votes-result (lw2-graphql-query (lw2-query-string :comment :list (alist :tag-id tag-id :view "commentsOnTag") :fields '(:--id :current-user-vote :current-user-extended-vote))
688 :auth-token auth-token))))
690 (define-backend-function get-post-comments (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
691 (backend-graphql
692 (let ((fn (lambda ()
693 (comments-list-to-graphql-json
694 (get-post-comments-list post-id "postCommentsTop")))))
695 (lw2-graphql-query-timeout-cached fn "post-comments-json" post-id :revalidate revalidate :force-revalidate force-revalidate)))
696 (backend-ea-forum
697 ;; Work around bizarre parent comment bug in EA forum
698 (declare (ignore revalidate force-revalidate))
699 (let ((comments (call-next-method)))
700 (dolist (c comments)
701 (if-let (parent-id-cons (assoc :parent-comment-id c))
702 (if (and (string= (cdr parent-id-cons) "rjgZaK8uzHG3jAu2p")
703 (not (string= post-id "h26Kx7uGfQfNewi7d")))
704 (setf (cdr parent-id-cons) nil))))
705 comments)))
707 (defun get-post-answers (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
708 (let ((fn (lambda ()
709 (let ((answers (get-post-comments-list post-id "questionAnswers")))
710 (comments-list-to-graphql-json
711 (nconc
712 answers
713 (get-post-answer-replies post-id answers)))))))
714 (lw2-graphql-query-timeout-cached fn "post-answers-json" post-id :revalidate revalidate :force-revalidate force-revalidate)))
716 (defun sequence-iterate (sequence fn)
717 (dolist (chapter (cdr (assoc :chapters sequence)))
718 (dolist (post (cdr (assoc :posts chapter)))
719 (funcall fn post))))
721 (defun sequence-post-ids (sequence)
722 (with-collector (col)
723 (sequence-iterate sequence
724 (lambda (post)
725 (col (cdr (assoc :--id post)))))
726 (col)))
728 (defun get-sequence-post (sequence post-id)
729 (sequence-iterate sequence
730 (lambda (post)
731 (when (string= (cdr (assoc :--id post)) post-id)
732 (return-from get-sequence-post post))))
733 nil)
735 (define-backend-function get-sequence (sequence-id)
736 (backend-graphql
737 (let ((fn (lambda ()
738 (multiple-value-bind (sequence sequence-json)
739 (lw2-graphql-query
740 (lw2-query-string :sequence :single
741 (alist :document-id sequence-id)
742 :fields `(:--id :title :created-at :user-id
743 (:contents :html)
744 (:chapters :title :subtitle :number (:contents :html) (:posts ,@(request-fields :post :list nil)))
745 :grid-image-id :----typename))
746 :return-type :both)
747 (let ((posts (sequence-post-ids sequence)))
748 (with-cache-transaction
749 (dolist (post-id posts)
750 (let ((old-seqs (cache-get "post-sequence" post-id :value-type :json)))
751 (unless (member sequence-id old-seqs :test #'string=)
752 (cache-put "post-sequence" post-id (cons sequence-id old-seqs) :value-type :json)))))
753 sequence-json)))))
754 (lw2-graphql-query-timeout-cached fn "sequence-json" sequence-id))))
756 (define-backend-function get-post-sequence-ids (post-id)
757 (backend-graphql
758 (cache-get "post-sequence" post-id :value-type :json)))
760 (defun preload-sequences-cache ()
761 (declare (optimize space (compilation-speed 2) (speed 0)))
762 (let ((sequences (apply #'append
763 (loop for view in '("curatedSequences" "communitySequences")
764 collect (lw2-graphql-query (lw2-query-string :sequence :list (alist :view view) :fields '(:--id)))))))
765 (dolist (sequence sequences)
766 (get-sequence (cdr (assoc :--id sequence))))
767 (format t "Retrieved ~A sequences." (length sequences)))
768 (values))
770 (define-backend-function user-deleted (user-id &optional (status nil set))
771 (backend-base
772 (declare (ignore user-id status set))
773 nil)
774 (backend-lw2-modernized
775 (if set
776 (if status
777 (cache-put "user-deleted" user-id "1")
778 (cache-del "user-deleted" user-id))
779 (cache-get "user-deleted" user-id :return-type 'existence))))
781 (define-backend-function get-user (user-identifier-type user-identifier &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
782 (backend-graphql
783 (let* ((user-id (ccase user-identifier-type
784 (:user-id user-identifier)
785 (:user-slug (get-slug-userid user-identifier))))
786 (query-string (lw2-query-string :user :single (alist :document-id user-id) :fields (list-cond* (auth-token :last-notifications-check) (user-fields))))
787 (result (if auth-token
788 (lw2-graphql-query query-string :auth-token auth-token)
789 (lw2-graphql-query-timeout-cached query-string "user-json" user-id :revalidate revalidate :force-revalidate force-revalidate))))
790 (alist-bind ((user-id (or simple-string null) :--id)
791 (display-name (or simple-string null))
792 (full-name (or simple-string null))
793 (slug (or simple-string null))
794 (deleted boolean))
795 result
796 (when user-id
797 (with-cache-transaction
798 (when display-name
799 (cache-username user-id display-name))
800 (when full-name
801 (cache-user-full-name user-id full-name))
802 (when slug
803 (cache-user-slug user-id slug)
804 (cache-slug-userid slug user-id))
805 (user-deleted user-id deleted))))
806 result)))
808 (define-backend-function get-notifications (&key user-id (offset 0) (limit 21) auth-token)
809 (backend-lw2-legacy
810 (lw2-graphql-query (lw2-query-string :notification :list
811 (alist* :user-id user-id :limit limit :offset offset *notifications-base-terms*)
812 :fields '(:--id :document-type :document-id :link :title :message :type :viewed))
813 :auth-token auth-token))
814 (backend-lw2-modernized
815 (declare (ignore user-id offset limit auth-token))
816 (let ((*notifications-base-terms* (remove :null *notifications-base-terms* :key #'cdr)))
817 (call-next-method))))
819 (define-backend-function check-notifications (user-id auth-token &key full since)
820 (backend-lw2-legacy
821 (multiple-value-bind (notifications user-info)
822 (lw2-graphql-query-multi (list
823 (lw2-query-string* :notification :list (alist* :user-id user-id :limit (if full 3 1) *notifications-base-terms*)
824 :fields (if full '(:--id :message :created-at) '(:created-at)))
825 (lw2-query-string* :user :single (alist :document-id user-id) :fields '(:last-notifications-check)))
826 :auth-token auth-token)
827 (let ((last-check (or since
828 (let ((last-check-string (cdr (assoc :last-notifications-check user-info))))
829 (when (and (stringp last-check-string) (not (equal last-check-string "")))
830 (local-time:parse-timestring last-check-string))))))
831 (when notifications
832 (labels ((unread-p (notification)
833 (if last-check
834 (local-time:timestamp>
835 (local-time:parse-timestring (cdr (assoc :created-at notification)))
836 last-check)
837 ;; User has never checked notifications before -- all are unread
838 t)))
839 (if full
840 (remove-if-not #'unread-p notifications)
841 (unread-p (first notifications))))))))
842 (backend-lw2-modernized
843 (declare (ignore user-id auth-token full since))
844 (let ((*notifications-base-terms* (remove :null *notifications-base-terms* :key #'cdr)))
845 (call-next-method))))
847 (define-cache-database 'backend-lw2-legacy "comment-reply-by-user")
849 (define-backend-function mark-comment-replied (reply)
850 (backend-lw2-legacy
851 (alexandria:when-let* ((parent-comment-id (cdr (assoc :parent-comment-id reply)))
852 (reply-id (cdr (assoc :--id reply)))
853 (user-id (cdr (assoc :user-id reply))))
854 (cache-put "comment-reply-by-user" (concatenate 'string parent-comment-id " " user-id) reply-id))))
856 (define-backend-function check-comment-replied (comment-id user-id)
857 (backend-lw2-legacy
858 (cache-get "comment-reply-by-user" (concatenate 'string comment-id " " user-id))))
860 (define-backend-function get-user-page-items (user-id request-type &key (offset 0) (limit 21) (sort-type :date) drafts
861 (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
862 (backend-lw2-legacy
863 (multiple-value-bind (real-offset real-limit) (if (eq request-type :both)
864 (values 0 (+ offset limit))
865 (values offset limit))
866 (let* ((cache-database (when (and (eq request-type :both)
867 (or (not offset) (= offset 0))
868 (= limit 21)
869 (eq sort-type :date)
870 (not drafts)
871 (not auth-token))
872 "user-page-items"))
873 (return-type (if cache-database :string nil))
874 (fn (lambda ()
875 (labels ((posts-query-string ()
876 (let* ((base-terms
877 (cond
878 (drafts (alist :view "drafts"))
879 ((eq sort-type :score) (alist :view "top"))
880 ((eq sort-type :date-reverse) (alist :view "old"))
881 (t (alist :view "userPosts"))))
882 (terms (alist* :offset real-offset :limit real-limit :user-id user-id base-terms)))
883 (declare (dynamic-extent base-terms terms))
884 (lw2-query-string* :post :list terms)))
885 (comments-query-string ()
886 (let* ((view (ecase sort-type
887 (:score "postCommentsTop")
888 (:date "allRecentComments")
889 (:date-reverse "postCommentsOld")))
890 (terms (alist :offset real-offset
891 :limit real-limit
892 :user-id user-id
893 :view view)))
894 (declare (dynamic-extent view terms))
895 (lw2-query-string* :comment :list terms
896 :context :index))))
897 (declare (dynamic-extent #'posts-query-string #'comments-query-string))
898 (case request-type
899 (:both (let ((result (multiple-value-call #'concatenate 'list
900 (lw2-graphql-query-multi (list (posts-query-string) (comments-query-string))))))
901 (ecase return-type
902 (:string (json:encode-json-to-string result))
903 ((nil) result))))
904 (:posts (lw2-graphql-query (format nil "{~A}" (posts-query-string)) :auth-token auth-token :return-type return-type))
905 (:comments (lw2-graphql-query (format nil "{~A}" (comments-query-string)) :auth-token auth-token :return-type return-type)))))))
906 (if cache-database
907 (lw2-graphql-query-timeout-cached fn cache-database user-id :decoder 'deserialize-query-result :revalidate revalidate :force-revalidate force-revalidate)
908 (funcall fn))))))
910 (define-backend-function get-conversation-messages (conversation-id auth-token)
911 (backend-lw2-legacy
912 (lw2-graphql-query-multi
913 (list
914 (lw2-query-string* :conversation :single (alist :document-id conversation-id) :fields '(:title (:participants :display-name :slug)))
915 (lw2-query-string* :message :list (alist :view "messagesConversation" :conversation-id conversation-id) :fields *messages-index-fields*))
916 :auth-token auth-token)))
918 (define-backend-function lw2-search-query (query)
919 (backend-algolia-search
920 (call-with-http-response
921 (lambda (req-stream)
922 (values-list (loop for r in (cdr (assoc :results (json:decode-json req-stream)))
923 collect (cdr (assoc :hits r)))))
924 (algolia-search-uri *current-backend*)
925 :method :post
926 :headers '(("Origin" . "https://www.greaterwrong.com")
927 ("Referer" . "https://www.greaterwrong.com/")
928 ("Content-Type" . "application/json"))
929 :content (json:encode-json-alist-to-string
930 (alist "requests" (loop for index in '("test_tags" "test_posts" "test_comments")
931 collect (alist "indexName" index
932 "params" (format nil "query=~A&hitsPerPage=20&page=0"
933 (url-rewrite:url-encode query))))))
934 :want-stream t)))
936 (define-backend-function get-username-wrapper (user-id fn)
937 (backend-base
938 (funcall fn user-id))
939 (backend-lw2-modernized
940 (if (user-deleted user-id)
941 "[deleted]"
942 (funcall fn user-id))))
944 (define-cache-database 'backend-lw2-legacy "comment-markdown-source" "post-markdown-source")
946 (defun markdown-source-db-name (target-type)
947 (ecase target-type (:comment "comment-markdown-source") (:post "post-markdown-source")))
949 (define-backend-function markdown-source (target-type id version)
950 (backend-lw2-modernized
951 (let ((db-name (markdown-source-db-name target-type))
952 (version (base64:usb8-array-to-base64-string (hash-string version))))
954 (if-let ((cache-data (cache-get db-name id :value-type :lisp)))
955 (alist-bind ((cached-version simple-string :version)
956 (markdown simple-string))
957 cache-data
958 (when (string= version cached-version)
959 markdown)))
960 (trivia:ematch (lw2-graphql-query (lw2-query-string target-type :single
961 (alist :document-id id)
962 :fields '(:html-body (:contents :markdown)))
963 :auth-token *current-auth-token*)
964 ((trivia:alist (:html-body . html-body)
965 (:contents . (assoc :markdown markdown)))
966 (cache-put db-name id (alist :version (base64:usb8-array-to-base64-string (hash-string html-body)) :markdown markdown) :value-type :lisp)
967 markdown))))))
969 (define-backend-function (setf markdown-source) (markdown target-type id version)
970 (backend-lw2-modernized
971 (let ((version (base64:usb8-array-to-base64-string (hash-string version))))
972 (cache-put (markdown-source-db-name target-type)
974 (alist :version version :markdown markdown)
975 :value-type :lisp))))
977 (defun get-elicit-question-title (question-id)
978 (cdr
979 (lw2-graphql-query (graphql-query-string "ElicitBlockData" (alist :question-id question-id) '(:title)))))
981 (defun make-rate-limiter (delay)
982 (let ((rl-hash (make-hash-table :test 'equal :synchronized t)))
983 (lambda (datum fn)
984 (let ((unix-time (get-unix-time)))
985 (if (sb-ext:with-locked-hash-table (rl-hash)
986 (maphash (lambda (k v)
987 (if (> (- unix-time v) delay)
988 (remhash k rl-hash)))
989 rl-hash)
990 (not (gethash datum rl-hash)))
991 (progn
992 (setf (gethash datum rl-hash) unix-time)
993 (funcall fn))
994 (error "Request aborted due to rate limit."))))))
996 (defmacro with-rate-limit (&body outer-body)
997 `(let ((rate-limiter (make-rate-limiter 30)))
998 (macrolet ((rate-limit ((key) &body inner-body)
999 `(funcall rate-limiter ,key (lambda () ,@inner-body))))
1000 ,@outer-body)))
1002 (with-rate-limit
1003 (simple-cacheable ("post-title" 'backend-lw2-legacy "postid-to-title" post-id)
1004 (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) :fields '(:title))))))))
1006 (with-rate-limit
1007 (simple-cacheable ("post-slug" 'backend-lw2-legacy "postid-to-slug" post-id)
1008 (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) :fields '(:slug))))))))
1010 (with-rate-limit
1011 (simple-cacheable ("slug-postid" 'backend-lw2-legacy "slug-to-postid" slug)
1012 (rate-limit (slug) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :slug slug) :fields '(:--id))))))))
1014 (with-rate-limit
1015 (simple-cacheable ("username" 'backend-lw2-legacy "userid-to-displayname" user-id :get-wrapper #'get-username-wrapper)
1016 (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) :fields '(:display-name))))))))
1018 (with-rate-limit
1019 (simple-cacheable ("user-slug" 'backend-lw2-legacy "userid-to-slug" user-id)
1020 (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) :fields '(:slug))))))))
1022 (with-rate-limit
1023 (simple-cacheable ("user-full-name" 'backend-lw2-legacy "userid-to-full-name" user-id)
1024 (rate-limit (user-id) (or (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) :fields '(:full-name)))))
1025 ""))))
1027 (with-rate-limit
1028 (simple-cacheable ("slug-userid" 'backend-lw2-legacy "slug-to-userid" slug)
1029 (rate-limit (slug) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :slug slug) :fields '(:--id))))))))
1031 (with-rate-limit
1032 (simple-cacheable ("slug-tagid" 'backend-lw2-tags "slug-to-tagid" slug :catch-errors nil)
1033 (rate-limit (slug) (cdr (first (first (lw2-graphql-query (lw2-query-string :tag :list (alist :view "tagBySlug" :slug slug) :fields '(:--id)))))))))
1035 (defun preload-username-cache ()
1036 (declare (optimize space (compilation-speed 2) (speed 0)))
1037 (let ((user-list (lw2-graphql-query (lw2-query-string :user :list '() :fields '(:--id :slug :display-name)))))
1038 (with-cache-transaction
1039 (loop for user in user-list
1040 do (alist-bind ((user-id (or simple-string null) :--id)
1041 (slug (or simple-string null))
1042 (display-name (or simple-string null)))
1043 user
1044 (when user-id
1045 (when display-name
1046 (cache-username user-id display-name))
1047 (when slug
1048 (cache-user-slug user-id slug)
1049 (cache-slug-userid slug user-id))))))))