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
#:alexandria-2
#:subseq
*)
5 (:import-from
#:collectors
#:with-collector
)
6 (:import-from
#:lw2.user-context
#:*current-auth-token
*)
7 (:reexport
#:lw2.backend-modules
)
8 (:export
#:*use-alignment-forum
*
10 #:*graphql-debug-output
*
11 #:*revalidate-default
* #:*force-revalidate-default
*
12 #:*messages-index-fields
*
13 #:*notifications-base-terms
*
15 #:start-background-loader
#:stop-background-loader
#:background-loader-running-p
16 #:call-with-http-response
17 #:forwarded-header
#:backend-request-headers
18 #:lw2-graphql-query
#:lw2-query-string
* #:lw2-query-string
19 #:lw2-graphql-query-map
#:lw2-graphql-query-multi
22 #:flatten-shortform-comments
#:get-shortform-votes
24 #:get-post-tag-votes
#:get-tag-post-votes
26 #:get-posts-index
#:get-posts-json
#:get-post-body
#:get-post-vote
#:get-post-comments
#:get-post-answers
#:get-post-debate-responses
27 #:get-post-comments-votes
28 #:get-tag-comments-votes
29 #:get-recent-comments
#:get-recent-comments-json
31 #:sequence-post-ids
#:get-sequence
#:get-post-sequence-ids
#:get-sequence-post
32 #:get-conversation-messages
35 #:get-notifications
#:check-notifications
36 #:mark-comment-replied
#:check-comment-replied
37 #:lw2-search-query
#:get-post-title
#:get-post-slug
#:get-slug-postid
#:get-username
#:get-user-full-name
#:get-user-slug
38 #:do-wl-rest-mutate
#:do-wl-rest-query
#:do-wl-create-tag
)
39 (:recycle
#:lw2-viewer
)
40 (:unintern
#:get-posts
#:make-posts-list-query
#:define-backend-fields
41 #:*posts-index-fields
* #:posts-index-fields
#:post-body-fields
42 #:*comments-index-fields
* #:comments-index-fields
43 #:*post-comments-fields
* #:post-comments-fields
44 #:define-index-fields
#:decode-graphql-json
45 #:lw2-graphql-query-noparse
#:lw2-graphql-query-streamparse
47 #:with-connection-pool
#:call-with-connection-pool
50 (in-package #:lw2.backend
)
52 ;; Dexador settings required for the system to work properly.
53 (setf dex
:*default-connect-timeout
* nil
54 dex
:*default-read-timeout
* nil
55 dex
:*use-connection-pool
* nil
)
57 (defvar *use-alignment-forum
* nil
)
58 (defvar *graphql-uri-hook
* #'identity
)
60 (defvar *graphql-debug-output
* nil
)
62 (defvar *revalidate-default
* t
)
63 (defvar *force-revalidate-default
* nil
)
65 (defparameter *messages-index-fields
* '(:--id
:user-id
:created-at
(:contents
:html
) (:conversation
:--id
:title
) :----typename
))
66 (defparameter *user-fields
* '(:--id
:slug
:display-name
:karma
))
68 (defparameter *notifications-base-terms
* (alist :view
"userNotifications" :created-at
:null
:viewed
:null
))
70 (defun request-fields (query-type return-type context
)
71 "Returns the desired fields for a given type of request."
76 (let ((backend *current-backend
*)
77 (schema-type (find-schema-type query-type
))
78 (added (make-hash-table :test
'eq
)))
79 (dolist (field (cdr (assoc :fields schema-type
)) (col))
80 (destructuring-bind (field-name field-type
&key alias backend-type graphql-ignore subfields
((:context field-context
)) context-not
&allow-other-keys
) field
81 (declare (ignore field-type
))
82 (when (and (not (gethash field-name added
))
84 (or (not backend-type
) (typep backend backend-type
))
85 (or (not field-context
) (eq context field-context
))
86 (or (not context-not
) (not (eq context context-not
))))
87 (setf (gethash field-name added
) t
)
89 (let ((result-name (or alias field-name
)))
91 (list* result-name subfields
)
92 result-name
)))))))))))
94 (define-backend-function user-fields
()
95 (backend-lw2-legacy (load-time-value *user-fields
*))
96 (backend-lw2-modernized (append (call-next-method) '(:groups
:deleted
:html-bio
)))
97 (backend-alignment-forum (append (call-next-method) '(:af-karma
:full-name
))))
99 (define-cache-database 'backend-lw2-legacy
100 "index-json" "index-json-meta"
101 "post-comments-json" "post-comments-json-meta" "post-answers-json" "post-answers-json-meta"
102 "post-body-json" "post-body-json-meta"
103 "sequence-json" "sequence-json-meta" "post-sequence"
104 "user-json" "user-json-meta"
105 "user-page-items" "user-page-items-meta")
107 (define-cache-database 'backend-lw2-modernized
110 (define-backend-function comments-list-to-graphql-json
(comments-list)
112 (json:encode-json-to-string
113 (plist-hash-table (list :data
(plist-hash-table (list :*comments-list comments-list
))))))
114 (backend-lw2-modernized
115 (json:encode-json-to-string
116 (plist-hash-table (list :data
(plist-hash-table (list :*comments-list
(plist-hash-table (list :results comments-list
)))))))))
118 (defun do-graphql-debug (query)
119 (when *graphql-debug-output
*
120 (format *graphql-debug-output
* "~&GraphQL query: ~A~%" query
)))
122 (defmacro with-retrying
((maybe-retry-fn-name &key retries before-maybe-retry before-retry
) &body body
)
123 (with-gensyms (remaining-retries retry
)
124 `(let ((,remaining-retries
,retries
))
126 (labels ((,maybe-retry-fn-name
()
128 (when (> ,remaining-retries
0)
129 (decf ,remaining-retries
)
134 (defun force-close (stream)
135 (ignore-errors (close stream
:abort t
)))
137 (sb-ext:defglobal
*connection-pool
* (make-hash-table :test
'equal
))
138 (sb-ext:defglobal
*connection-pool-lock
* (sb-thread:make-mutex
:name
"*connection-pool-lock*"))
139 (sb-ext:defglobal
*connection-pool-entries-per-origin
* 8)
141 (defun connection-push (dest connection
)
142 (let ((connection-pool *connection-pool
*)
144 (sb-thread:with-mutex
(*connection-pool-lock
*)
145 (let ((vector (or (gethash dest connection-pool
)
146 (setf (gethash dest connection-pool
)
147 (make-array *connection-pool-entries-per-origin
* :fill-pointer
0)))))
148 (unless (vector-push connection vector
)
149 (setf old-connection
(vector-pop vector
))
150 (vector-push connection vector
))))
152 (force-close old-connection
))))
154 (defun connection-pop (dest)
155 (let ((connection-pool *connection-pool
*))
156 (sb-thread:with-mutex
(*connection-pool-lock
*)
157 (when-let (vector (gethash dest connection-pool
))
158 (when (> (fill-pointer vector
) 0)
159 (vector-pop vector
))))))
161 (defun clear-connection-pool ()
162 (let ((connection-pool *connection-pool
*))
163 (sb-thread:with-mutex
(*connection-pool-lock
*)
165 (lambda (dest vector
)
166 (loop for connection across vector
167 do
(force-close connection
))
168 (remhash dest connection-pool
))
171 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
172 (defstruct (token-bucket (:constructor %make-token-bucket
))
173 (tokens internal-time-units-per-second
:type fixnum
)
174 (base-cost internal-time-units-per-second
:type fixnum
)
175 (last-update (get-internal-real-time) :type fixnum
)
176 (tokens-per-unit 1 :type fixnum
)
177 (token-limit internal-time-units-per-second
:type fixnum
))
179 (defun make-token-bucket (&key rate burst
(fill-ratio 1.0))
180 (let* ((scaled-rate (rationalize (/ internal-time-units-per-second rate
)))
181 (base-cost (numerator scaled-rate
))
182 (tokens-per-unit (denominator scaled-rate
))
183 (token-limit (* base-cost burst
)))
186 :tokens-per-unit tokens-per-unit
187 :token-limit token-limit
188 :tokens
(round (* token-limit fill-ratio
))))))
190 (defun token-bucket-decrement (token-bucket n
&optional with-punishment
)
191 (let* ((time (get-internal-real-time))
192 (tpu (token-bucket-tokens-per-unit token-bucket
))
193 (limit (token-bucket-token-limit token-bucket
))
194 (cost (round (* n
(token-bucket-base-cost token-bucket
))))
195 (max-increment (+ limit cost
))
196 (max-timediff (ceiling max-increment tpu
))
199 (declare (type (and fixnum
(integer 0)) time
)
200 (type (unsigned-byte 32) limit cost max-increment increment
)
201 (type (integer 1 10000000) tpu
))
202 (sb-ext:atomic-update
(token-bucket-last-update token-bucket
)
204 (declare (type (and fixnum
(integer 0)) previous
))
205 (if (> (- time max-timediff
) previous
)
206 (setf increment max-increment
)
207 (let ((timediff (- time
(min previous time
))))
208 (declare (type (unsigned-byte 32) timediff
))
209 (setf increment
(* timediff tpu
))))
210 (max previous time
)))
211 (sb-ext:atomic-update
(token-bucket-tokens token-bucket
)
213 (declare (type (signed-byte 32) previous
))
214 (let* ((new-refill (+ previous increment
))
215 (new (- new-refill cost
)))
216 (setf result
(> new
0))
217 (if (or result with-punishment
)
219 (max (- limit
) (min new-refill limit
))))))
222 (defun parse-ipv4 (string)
223 (let ((l (map 'list
#'parse-integer
224 (split-sequence:split-sequence
#\. string
))))
227 do
(setf res
(+ n
(ash res
8)))
228 finally
(return res
))))
230 (defvar *enable-rate-limit
* t
)
232 (defparameter *rate-limit-cost-factor
* 1)
234 (sb-ext:defglobal
*global-token-bucket
* (make-token-bucket :rate
3 :burst
180))
236 (defun check-rate-limit ()
237 (or (token-bucket-decrement *global-token-bucket
* *rate-limit-cost-factor
*)
238 (error "Rate limit exceeded. Try again later.")))
240 (defun call-with-http-response (fn uri-string
&rest args
&key
&allow-other-keys
)
241 (when *enable-rate-limit
*
243 (let* ((uri (quri:uri uri-string
))
244 (uri-dest (concatenate 'string
(quri:uri-host uri
) ":" (format nil
"~d" (quri:uri-port uri
))))
245 (stream (connection-pop uri-dest
)))
246 (let (response status-code headers response-uri new-stream success
)
247 (with-retrying (maybe-retry :retries
3
248 :before-retry
(sleep 0.2))
250 (handler-bind (((or dex
:http-request-failed usocket
:ns-condition usocket
:socket-condition
)
252 (if-let ((r (find-restart 'dex
:ignore-and-continue condition
))
253 (ct (gethash "content-type" (dex:response-headers condition
))))
254 (if (ppcre:scan
"^application/json" ct
)
257 (setf (values response status-code headers response-uri new-stream
)
258 (apply 'dex
:request uri
:use-connection-pool nil
:keep-alive t
:stream stream args
))
259 (unless (eq stream new-stream
)
260 (when stream
(force-close stream
))
261 (setf stream new-stream
263 (when (<= 500 status-code
599)
265 (error 'lw2-connection-error
:message
(format nil
"HTTP status ~A" status-code
)))
268 (when (streamp response
)
269 (force-close response
))
271 (force-close stream
))
274 (funcall fn response
)
275 (when (streamp response
)
277 (when stream
; the connection is reusable
278 (connection-push uri-dest stream
))))))
280 (defun forwarded-header ()
281 (let ((addr (and (boundp 'hunchentoot
:*request
*) (hunchentoot:real-remote-addr
))))
282 (list-cond (addr "X-Forwarded-For" addr
))))
284 (defun signal-lw2-errors (errors)
285 (loop for error in errors
286 do
(let ((message (cdr (assoc :message error
)))
287 (path (cdr (assoc :path error
))))
288 (unless (and path
(> (length path
) 1))
290 ((search "document_not_found" message
) (error 'lw2-not-found-error
))
291 ((search "app.missing_document" message
) (error 'lw2-not-found-error
))
292 ((search "only visible to logged-in users" message
) (error 'lw2-login-required-error
))
293 ((search "not_allowed" message
) (error 'lw2-not-allowed-error
))
294 (t (error 'lw2-unknown-error
:message message
)))))))
296 (define-backend-function earliest-post-time
()
297 (backend-lw2 (load-time-value (local-time:parse-timestring
"2005-01-01")))
298 (backend-ea-forum (load-time-value (local-time:parse-timestring
"2011-11-24")))
299 (backend-progress-forum (load-time-value (local-time:parse-timestring
"2022-03-26"))))
301 (define-backend-function fixup-lw2-return-value
(value)
304 (backend-lw2-modernized
306 (let ((x (first value
)))
307 (if (member (car x
) '(:result
:results
:total-count
))
310 (let ((x (second value
)))
311 (if (eq (car x
) :total-count
)
316 (define-backend-function deserialize-query-result
(result-source)
318 (let ((string-source (typecase result-source
322 (flexi-streams:make-in-memory-input-stream result-source
))
324 (ensure-character-stream result-source
)))))
325 (json:decode-json-from-source string-source
))))
327 (define-backend-function postprocess-query-result
(result)
331 (signal-lw2-errors (cdr (assoc :errors result
)))
332 (fixup-lw2-return-value (cdadr (assoc :data result
)))))
334 (define-backend-function decode-query-result
(result-source)
336 (postprocess-query-result
337 (deserialize-query-result result-source
))))
339 (defmethod graphql-uri ((backend backend-alignment-forum
))
340 (if *use-alignment-forum
*
341 "https://www.alignmentforum.org/graphql"
344 (define-backend-function backend-request-headers
(auth-token forwarded
)
345 (backend-websocket-login
346 (list-cond* (auth-token :authorization auth-token
)
348 (backend-passport-js-login
349 (list-cond* (auth-token :cookie
(concatenate 'string
"loginToken=" auth-token
))
351 (backend-oauth2.0-login
352 (list-cond* (auth-token :cookie
(concatenate 'string
"clientId=" (oauth2.0-client-id backend
) "; loginToken=" auth-token
))
355 (alist* :content-type
"application/json"
356 (if forwarded
(forwarded-header)))))
358 (define-backend-function call-with-backend-response
(fn query
&key return-type auth-token
)
360 (call-with-http-response
362 (funcall *graphql-uri-hook
* (graphql-uri *current-backend
*))
364 :headers
(backend-request-headers auth-token nil
)
365 :content
(dynamic-let ((q (alist :query query
))) (json:encode-json-to-string q
))
366 :want-stream
(not return-type
))))
368 (define-backend-function lw2-graphql-query
(query &key auth-token return-type
(decoder 'decode-query-result
))
370 (do-graphql-debug query
)
371 (call-with-backend-response
375 (:both
(lambda (string) (values (funcall decoder string
) string
))))
377 :return-type return-type
378 :auth-token auth-token
)))
380 (defun lw2-graphql-query-map (fn data
&key auth-token postprocess
)
381 (multiple-value-bind (map-values queries
)
383 as out-values
= (multiple-value-list (funcall fn d
))
384 as
(out passthrough-p
) = out-values
385 collect out-values into map-values
386 when
(not passthrough-p
) collect out into queries
387 finally
(return (values map-values queries
)))
389 (with-output-to-string (stream)
393 do
(format stream
"g~6,'0D:~A " n q
))
394 (format stream
"}")))
395 (query-result-data (when queries
(lw2-graphql-query query-string
:decoder
'deserialize-query-result
:auth-token auth-token
)))
396 (errors (cdr (assoc :errors query-result-data
))))
397 (signal-lw2-errors errors
)
399 (loop as results
= (sort (cdr (assoc :data query-result-data
)) #'string
< :key
#'car
) then
(if passthrough-p results
(rest results
))
400 for
(out passthrough-p
) in map-values
401 as result-data-cell
= (first results
)
402 as result-data
= (if passthrough-p out
(fixup-lw2-return-value (cdr result-data-cell
)))
403 for input-data in data
404 collect
(if postprocess
(funcall postprocess input-data result-data
) result-data
))
407 (defun lw2-graphql-query-multi (query-list &key auth-token
)
408 (values-list (lw2-graphql-query-map #'identity query-list
:auth-token auth-token
)))
410 (defvar *background-cache-update-threads
* (make-hash-table :test
'equal
414 (defvar *parsed-results-cache
* (make-hash-table :test
'equal
418 (defun cache-update (cache-db key data
)
419 (let ((meta-db (format nil
"~A-meta" cache-db
))
420 (new-hash (hash-string data
))
421 (current-time (get-unix-time)))
422 (with-cache-transaction
423 (let* ((metadata (cache-get meta-db key
:value-type
:lisp
))
424 (same-data (equalp new-hash
(cdr (assoc :city-128-hash metadata
))))
425 (last-mod (if same-data
426 (or (cdr (assoc :last-modified metadata
)) current-time
)
428 (cache-put meta-db key
(alist :last-checked current-time
:last-modified last-mod
:city-128-hash new-hash
) :value-type
:lisp
)
430 (remhash (list *current-backend
* cache-db key
) *parsed-results-cache
*)
431 (cache-put cache-db key data
))
432 (values data
(unix-to-universal-time last-mod
))))))
434 (defun cache-mark-stale (cache-db key
)
435 (let ((meta-db (format nil
"~A-meta" cache-db
))
436 (current-time (get-unix-time)))
437 (with-cache-transaction
438 (let* ((metadata (cache-get meta-db key
:value-type
:lisp
))
439 (metadata (alist* :last-modified current-time
(delete :last-modified metadata
:key
#'car
))))
440 (cache-put meta-db key metadata
:value-type
:lisp
)))))
442 (declaim (type (and fixnum
(integer 1)) *cache-stale-factor
* *cache-skip-factor
*))
443 (defparameter *cache-stale-factor
* 100)
444 (defparameter *cache-skip-factor
* 5000)
446 (defun cache-freshness-status (cache-db key
)
447 (with-cache-readonly-transaction
448 (when (cache-exists cache-db key
)
449 (let ((metadata (cache-get (format nil
"~A-meta" cache-db
) key
:value-type
:lisp
))
450 (current-time (get-unix-time)))
451 (if-let ((last-mod (cdr (assoc :last-modified metadata
)))
452 (last-checked (cdr (assoc :last-checked metadata
))))
454 (let ((unmodified-time (- last-checked last-mod
))
455 (last-checked-time (- current-time last-checked
)))
456 (if (> unmodified-time
(* *cache-skip-factor
* last-checked-time
))
458 (> unmodified-time
(* *cache-stale-factor
* last-checked-time
))))
460 (unix-to-universal-time last-mod
)))))))
462 (defgeneric run-query
(query)
463 (:method
((query string
))
464 (lw2-graphql-query query
:return-type
:string
))
465 (:method
((query function
))
468 (declaim (inline make-thread-with-current-backend
))
470 (defun make-thread-with-current-backend (fn &rest args
)
471 (let ((current-backend *current-backend
*))
472 (apply #'sb-thread
:make-thread
474 (let ((*current-backend
* current-backend
))
478 (defun ensure-cache-update-thread (query cache-db cache-key
)
479 (let ((key (format nil
"~A-~A" cache-db cache-key
)))
480 (labels ((background-fn ()
483 (multiple-value-bind (value error
)
484 (log-and-ignore-errors
485 (sb-sys:with-deadline
(:seconds
60)
486 (return (cache-update cache-db cache-key
(run-query query
)))))
487 (declare (ignore value
))
489 (remhash key
*background-cache-update-threads
*))))
490 (sb-ext:with-locked-hash-table
(*background-cache-update-threads
*)
491 (let ((thread (gethash key
*background-cache-update-threads
*)))
493 (setf (gethash key
*background-cache-update-threads
*)
494 (make-thread-with-current-backend #'background-fn
:name
"background cache update"))))))))
496 (define-backend-function lw2-graphql-query-timeout-cached
(query cache-db cache-key
&key
(decoder 'decode-query-result
)
497 (revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*))
499 (multiple-value-bind (is-fresh cached-result last-modified
)
500 (cache-freshness-status cache-db cache-key
)
501 (labels ((get-cached-result ()
502 (if-let ((parsed-result (gethash (list *current-backend
* cache-db cache-key
) *parsed-results-cache
*)))
503 (multiple-value-call #'values
(values-list parsed-result
) last-modified
)
504 (multiple-value-bind (result count
)
505 (with-cache-readonly-transaction (funcall decoder
(cache-get cache-db cache-key
:return-type
'binary-stream
)))
506 (setf (gethash (list *current-backend
* cache-db cache-key
) *parsed-results-cache
*) (list result count
))
507 (values result count last-modified
)))))
508 (if (and cached-result
(or (not revalidate
)
509 (and (not force-revalidate
) (eq is-fresh
:skip
))))
511 (let ((timeout (if cached-result
512 (if force-revalidate nil
3)
514 (thread (ensure-cache-update-thread query cache-db cache-key
)))
515 (block retrieve-result
516 (if (and cached-result
(if force-revalidate
(not revalidate
) (or is-fresh
(not revalidate
))))
519 ((fatal-error (lambda (c)
522 (return-from retrieve-result
(get-cached-result))))))
523 (multiple-value-bind (new-result last-modified
)
524 (sb-thread:join-thread thread
:timeout timeout
)
526 (condition (error new-result
))
527 (t (multiple-value-bind (result count
)
528 (funcall decoder new-result
)
529 (setf (gethash (list *current-backend
* cache-db cache-key
) *parsed-results-cache
*) (list result count
))
530 (values result count last-modified
))))))))))))))
532 (define-backend-function lw2-query-string
* (query-type return-type args
&key context fields with-total
))
534 (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
)
535 (declare (ignore with-total
))
536 (labels ((lisp-to-lw2-case (x) (json:lisp-to-camel-case
(format nil
"*~A" x
))))
537 (graphql-query-string*
539 (lisp-to-lw2-case query-type
)
541 (lisp-to-lw2-case return-type
))
542 (if (eq return-type
:single
)
547 (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
)
548 (graphql-query-string*
549 (if (eq return-type
:single
)
550 (json:lisp-to-camel-case
(string query-type
))
551 (concatenate 'string
(json:lisp-to-camel-case
(string query-type
)) "s"))
552 (alist :input
(case return-type
553 (:single
(alist :selector args
))
554 (:list
(alist :enable-total with-total
:terms args
))
555 (:total
(alist :enable-total t
:terms args
))))
557 (:total
'(:total-count
))
558 (:list
(list-cond (t :results fields
)
559 (with-total :total-count
)))
560 (:single
(alist :result fields
)))))
562 (define-backend-function lw2-query-string
(query-type return-type args
&key context fields with-total
))
564 (define-backend-operation lw2-query-string backend-lw2-legacy
(query-type return-type args
&rest rest
&key context fields with-total
)
565 (declare (ignore context fields with-total
))
566 (format nil
"{~A}" (apply 'lw2-query-string
* query-type return-type args rest
)))
568 (define-backend-function lw2-query-list-limit-workaround
(query-type terms
&rest rest
&key fields context auth-token
)
570 (declare (ignore fields context
))
572 (loop for offset from
0 by
500
573 as items-next
= (lw2-graphql-query (apply 'lw2-query-string query-type
:list
(alist* :limit
500 :offset offset terms
) (filter-plist rest
:fields
:context
))
574 :auth-token auth-token
)
575 as length
= (length items-next
)
576 do
(setf items-list
(nconc items-list items-next
))
577 while
(>= length
500))
580 (declare (ignore fields context
))
581 (lw2-graphql-query (apply 'lw2-query-string query-type
:list terms
(filter-plist rest
:fields
:context
)) :auth-token auth-token
)))
583 (defun get-cached-index-query (cache-id query
)
584 (multiple-value-bind (is-fresh cached-result last-modified
)
585 (cache-freshness-status "index-json" cache-id
)
586 (declare (ignore is-fresh
))
587 (labels ((query-and-put ()
588 (multiple-value-bind (encoded-result last-modified
)
589 (cache-update "index-json" cache-id
(lw2-graphql-query query
:return-type
:string
))
590 (multiple-value-bind (result count
)
591 (decode-query-result encoded-result
)
592 (values result count last-modified
))))
593 (get-cached-result ()
594 (with-cache-readonly-transaction
595 (multiple-value-bind (result count
)
596 (decode-query-result (cache-get "index-json" cache-id
:return-type
'binary-stream
))
597 (values result count last-modified
)))))
598 (if (and cached-result
(background-loader-ready-p))
603 (t () (get-cached-result)))
606 (define-backend-function get-posts-index-query-terms
(&key view
(sort "new") (limit 40) offset before after karma-threshold
&allow-other-keys
)
608 (let ((sort-key (alexandria:switch
(sort :test
#'string
=)
611 ("active" "recentComments")
614 (multiple-value-bind (view-terms cache-key
)
615 (alexandria:switch
(view :test
#'string
=)
616 ("featured" (alist :sorted-by sort-key
:filter
"curated"))
617 ("all" (alist :sorted-by sort-key
:filter
"all"))
618 ("alignment-forum" (alist :sorted-by sort-key
:af t
))
619 ("questions" (alist :sorted-by sort-key
:filter
"questions"))
620 ("events" (alist :sorted-by sort-key
:filter
"events"))
621 ("nominations" (alist :view
"nominations2019"))
622 ("reviews" (alist :view
"reviews2019"))
624 (alist :sorted-by sort-key
:filter
"frontpage")
625 (if (not (or (string/= sort
"new") (/= limit
40) offset before after karma-threshold
))
628 (alist-without-null* :before before
630 ;; Workaround offsets not working as of 2024-02-02
631 :limit
(if limit
(+ limit
(or offset
0)))
633 :karma-threshold karma-threshold
635 (values terms cache-key
))))))
637 (define-backend-operation get-posts-index-query-terms backend-lw2-tags
:around
(&key hide-tags
&allow-other-keys
)
638 (multiple-value-bind (query-terms cache-key
) (call-next-method)
640 (values (acons :filter-settings
(alist :tags
(list* :list
(map 'list
(lambda (tagid) (alist :tag-id tagid
:filter-mode
"Hidden"))
644 (values query-terms cache-key
))))
646 (define-backend-function get-posts-index-query-string
(&rest args
&key
&allow-other-keys
)
648 (declare (dynamic-extent args
))
649 (multiple-value-bind (query-terms cache-key
)
650 (apply #'%get-posts-index-query-terms backend args
)
651 (values (lw2-query-string :post
:list query-terms
)
654 (define-backend-function get-posts-index
(&rest args
&key
(limit 40) offset
&allow-other-keys
)
656 (declare (dynamic-extent args
))
657 (multiple-value-bind (query-string cache-key
)
658 (apply #'%get-posts-index-query-string backend args
)
660 (get-cached-index-query cache-key query-string
)
661 (let ((result (lw2-graphql-query query-string
))
662 (offset (or offset
0)))
663 ;; Workaround offsets not working as of 2024-02-02
665 (subseq* result offset
(+ limit offset
))
668 (define-backend-operation get-posts-index backend-lw2-tags
:around
(&rest args
&key hide-tags offset
(limit 40) &allow-other-keys
)
669 ;; Workaround for https://github.com/LessWrong2/Lesswrong2/issues/3099
670 (declare (dynamic-extent args
))
672 (let ((offset (or offset
0)))
674 (apply #'call-next-method backend
:offset
0 :limit
(+ limit offset
) args
)
678 (defun get-posts-json ()
679 (lw2-graphql-query (get-posts-index-query-string) :return-type
:string
))
681 (defun get-recent-comments (&key with-total
)
682 (get-cached-index-query "recent-comments" (lw2-query-string :comment
:list
'((:view .
"allRecentComments") (:limit .
20)) :context
:index
:with-total with-total
)))
684 (defun get-recent-comments-json ()
685 (lw2-graphql-query (lw2-query-string :comment
:list
'((:view .
"allRecentComments") (:limit .
20)) :context
:index
) :return-type
:string
))
687 (defun process-vote-result (res)
688 (alist-bind ((id (or null simple-string
) :--id
)
691 current-user-extended-vote
)
693 (let ((karma-vote (or (nonempty-string current-user-vote
)
694 (cdr (assoc :vote-type
(first current-user-votes
))))))
695 (values (list-cond* (karma-vote :karma karma-vote
)
696 current-user-extended-vote
)
699 (defun process-votes-result (res)
700 (let ((hash (make-hash-table)))
702 (multiple-value-bind (vote id
) (process-vote-result v
)
704 (setf (gethash id hash
) vote
))))))
706 (defun flatten-shortform-comments (comments)
707 (let ((output comments
))
708 (loop for comment in comments do
709 (setf output
(append (cdr (assoc :latest-children comment
)) output
)))
712 (defun get-shortform-votes (auth-token &key
(offset 0) (limit 20))
713 (process-votes-result
714 (flatten-shortform-comments
715 (lw2-graphql-query (lw2-query-string :comment
:list
(alist :view
"shortform" :offset offset
:limit limit
)
716 :fields
'(:--id
:current-user-vote
:current-user-extended-vote
(:latest-children
:--id
:current-user-vote
:current-user-extended-vote
)))
717 :auth-token auth-token
))))
719 (defun get-post-vote (post-id auth-token
)
720 (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
)))
722 (define-cache-database 'backend-lw2-tags
"tag-posts" "tag-posts-meta" "post-tags" "post-tags-meta")
724 (define-backend-function get-tag-posts
(slug &key
(revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*))
725 (backend-base (declare (ignore revalidate force-revalidate
)) nil
)
727 (let* ((tagid (get-slug-tagid slug
))
729 (comments-list-to-graphql-json
730 (lw2-query-list-limit-workaround
732 (alist :view
"postsWithTag" :tag-id tagid
)
733 :fields
(list (list* :post
(request-fields :post
:list
:index
))))))))
735 (for x in
(lw2-graphql-query-timeout-cached query-fn
"tag-posts" tagid
:revalidate revalidate
:force-revalidate force-revalidate
))
736 (when-let (post (cdr (assoc :post x
)))
739 (define-backend-function get-tag-post-votes
(tag-id auth-token
)
740 (backend-base (progn tag-id auth-token nil
))
742 (process-votes-result
744 (lw2-query-list-limit-workaround
746 (alist :view
"postsWithTag" :tag-id tag-id
)
747 :fields
'(:--id
:current-user-vote
:current-user-extended-vote
)
748 :auth-token auth-token
)))))
750 (define-backend-function get-post-tags
(post-id &key
(revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*))
751 (backend-base (declare (ignore revalidate force-revalidate
)) nil
)
753 (let ((query-string (lw2-query-string :tag-rel
:list
(alist :view
"tagsOnPost" :post-id post-id
) :fields
'((:tag
:name
:slug
)))))
754 (lw2-graphql-query-timeout-cached query-string
"post-tags" post-id
:revalidate revalidate
:force-revalidate force-revalidate
))))
756 (define-backend-function get-post-tag-votes
(post-id auth-token
)
757 (backend-base (progn post-id auth-token nil
))
759 (process-votes-result
760 (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
))
761 :auth-token auth-token
))))
763 (define-backend-function get-post-body
(post-id &key
(revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*) auth-token
)
765 (let ((query-string (lw2-query-string :post
:single
(alist :document-id post-id
) :context
:body
)))
768 (handler-bind ((lw2-login-required-error (lambda (&rest args
)
769 (declare (ignore args
))
770 (let ((current-auth-token *current-auth-token
*))
771 (when (and (not auth-token
) current-auth-token
)
772 (setf auth-token current-auth-token
)
776 (lw2-graphql-query query-string
:auth-token auth-token
)
777 (lw2-graphql-query-timeout-cached query-string
"post-body-json" post-id
:revalidate revalidate
:force-revalidate force-revalidate
))))))))
779 (declare (ignore auth-token
))
780 (acons :tags
(get-post-tags post-id
:revalidate revalidate
:force-revalidate force-revalidate
) (call-next-method)))
781 (backend-magnum-crossposts
782 (declare (ignore auth-token
))
783 (let ((post (call-next-method)))
784 (alist-bind (is-crosspost hosted-here foreign-post-id
) (cdr (assoc :fm-crosspost post
))
785 (cond ((not (and (backend-magnum-crosspost-site backend
)
786 (not (boundp '*retrieve-crosspost
*))
787 is-crosspost foreign-post-id
))
791 (handler-bind ((error (lambda (condition)
792 (declare (ignore condition
))
794 (return (remove :fm-crosspost post
:key
#'car
))))))
795 (let* ((*current-site
* (find-site (backend-magnum-crosspost-site backend
)))
796 (*current-backend
* (site-backend *current-site
*))
797 (*retrieve-crosspost
* nil
)
798 (foreign-post (get-post-body foreign-post-id
:revalidate revalidate
:force-revalidate force-revalidate
))
799 (foreign-post-body (cdr (assoc :html-body foreign-post
))))
800 (declare (special *retrieve-crosspost
*))
801 (if foreign-post-body
803 ((not hosted-here
) :html-body foreign-post-body
)
804 (t :foreign-post foreign-post
)
808 (defun get-post-comments-list (post-id view
&rest rest
&key auth-token parent-answer-id fields context
)
809 (declare (ignore fields context auth-token
))
810 (let ((terms (alist :view view
:post-id post-id
)))
811 (when parent-answer-id
812 (setf terms
(acons :parent-answer-id parent-answer-id terms
)))
813 (apply 'lw2-query-list-limit-workaround
:comment terms
(filter-plist rest
:fields
:context
:auth-token
))))
815 (defun get-post-answer-replies (post-id answers
&rest rest
&key auth-token fields context
)
816 ;; todo: support more than 500 answers per question
817 (declare (ignore fields context
))
818 (let* ((terms (alist :view
"repliesToAnswer" :post-id post-id
:limit
500))
819 (result (lw2-graphql-query-map
821 (mapcar (lambda (answer) (apply 'lw2-query-string
* :comment
:list
822 (acons :parent-answer-id
(cdr (assoc :--id answer
)) terms
)
823 (filter-plist rest
:fields
:context
)))
825 :auth-token auth-token
)))
826 (apply #'nconc result
)))
828 (define-backend-function get-post-comments-votes
(post-id auth-token
)
830 (let ((fields '(:--id
:current-user-vote
:current-user-extended-vote
)))
831 (process-votes-result
832 (get-post-comments-list post-id
"postCommentsTop" :auth-token auth-token
:fields fields
))))
834 (let* ((fields '(:--id
:current-user-vote
:current-user-extended-vote
))
835 (answers (get-post-comments-list post-id
"questionAnswers" :auth-token auth-token
:fields fields
)))
836 (process-votes-result
838 (get-post-comments-list post-id
"postCommentsTop" :auth-token auth-token
:fields fields
)
839 (get-post-answer-replies post-id answers
:auth-token auth-token
:fields fields
)
842 (define-backend-function get-tag-comments-votes
(tag-id auth-token
)
843 (backend-lw2-tags-comments
844 (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
))
845 :auth-token auth-token
))))
847 (define-backend-function get-post-comments
(post-id &key
(revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*))
850 (comments-list-to-graphql-json
851 (get-post-comments-list post-id
"postCommentsTop")))))
852 (lw2-graphql-query-timeout-cached fn
"post-comments-json" post-id
:revalidate revalidate
:force-revalidate force-revalidate
)))
854 ;; Work around bizarre parent comment bug in EA forum
855 (declare (ignore revalidate force-revalidate
))
856 (let ((comments (call-next-method)))
858 (if-let (parent-id-cons (assoc :parent-comment-id c
))
859 (if (and (string= (cdr parent-id-cons
) "rjgZaK8uzHG3jAu2p")
860 (not (string= post-id
"h26Kx7uGfQfNewi7d")))
861 (setf (cdr parent-id-cons
) nil
))))
864 (defun get-post-answers (post-id &key
(revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*))
866 (let ((answers (get-post-comments-list post-id
"questionAnswers")))
867 (comments-list-to-graphql-json
870 (get-post-answer-replies post-id answers
)))))))
871 (lw2-graphql-query-timeout-cached fn
"post-answers-json" post-id
:revalidate revalidate
:force-revalidate force-revalidate
)))
873 (define-cache-database 'backend-debates
874 "post-debate-responses-json" "post-debate-responses-json-meta")
876 (define-backend-function get-post-debate-responses
(post-id &key
(revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*))
878 (declare (ignore post-id revalidate force-revalidate
))
882 (comments-list-to-graphql-json
883 (get-post-comments-list post-id
"debateResponses")))))
884 (lw2-graphql-query-timeout-cached fn
"post-debate-responses-json" post-id
:revalidate revalidate
:force-revalidate force-revalidate
))))
886 (define-backend-function get-collection
(collection-id)
889 (lw2-query-string :collection
:single
890 (alist :document-id collection-id
)
891 :fields
`(:--id
:title
(:contents
:html
) :grid-image-id
:----typename
892 (:books
:title
:subtitle
(:contents
:html
) :----typename
893 (:sequences
:title
(:contents
:html
) :grid-image-id
:----typename
894 (:chapters
:title
:subtitle
:number
(:contents
:html
) (:posts
,@(request-fields :post
:list nil
))))))))))
896 (defun sequence-iterate (sequence fn
)
897 (dolist (chapter (cdr (assoc :chapters sequence
)))
898 (dolist (post (cdr (assoc :posts chapter
)))
901 (defun sequence-post-ids (sequence)
902 (with-collector (col)
903 (sequence-iterate sequence
905 (col (cdr (assoc :--id post
)))))
908 (defun get-sequence-post (sequence post-id
)
909 (sequence-iterate sequence
911 (when (string= (cdr (assoc :--id post
)) post-id
)
912 (return-from get-sequence-post post
))))
915 (define-backend-function get-sequence
(sequence-id)
918 (multiple-value-bind (sequence sequence-json
)
920 (lw2-query-string :sequence
:single
921 (alist :document-id sequence-id
)
922 :fields
`(:--id
:title
:created-at
:user-id
924 (:chapters
:title
:subtitle
:number
(:contents
:html
) (:posts
,@(request-fields :post
:list nil
)))
925 :grid-image-id
:----typename
))
927 (let ((posts (sequence-post-ids sequence
)))
928 (with-cache-transaction
929 (dolist (post-id posts
)
930 (let ((old-seqs (cache-get "post-sequence" post-id
:value-type
:json
)))
931 (unless (member sequence-id old-seqs
:test
#'string
=)
932 (cache-put "post-sequence" post-id
(cons sequence-id old-seqs
) :value-type
:json
)))))
934 (lw2-graphql-query-timeout-cached fn
"sequence-json" sequence-id
))))
936 (define-backend-function get-post-sequence-ids
(post-id)
938 (cache-get "post-sequence" post-id
:value-type
:json
)))
940 (defun preload-sequences-cache ()
941 (declare (optimize space
(compilation-speed 2) (speed 0)))
942 (let ((sequences (apply #'append
943 (loop for view in
'("curatedSequences" "communitySequences")
944 collect
(lw2-graphql-query (lw2-query-string :sequence
:list
(alist :view view
) :fields
'(:--id
)))))))
945 (dolist (sequence sequences
)
946 (get-sequence (cdr (assoc :--id sequence
))))
947 (format t
"Retrieved ~A sequences." (length sequences
)))
950 (define-backend-function user-deleted
(user-id &optional
(status nil set
))
952 (declare (ignore user-id status set
))
954 (backend-lw2-modernized
958 (cache-put "user-deleted" user-id
"1")
959 (cache-del "user-deleted" user-id
))
960 (cache-get "user-deleted" user-id
:return-type
'existence
)))))
962 (define-backend-function get-user
(user-identifier-type user-identifier
&key
(revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*) auth-token
)
964 (let* ((user-id (ccase user-identifier-type
965 (:user-id user-identifier
)
966 (:user-slug
(get-slug-userid user-identifier
))))
967 (query-string (lw2-query-string :user
:single
(alist :document-id user-id
) :fields
(list-cond* (auth-token :last-notifications-check
) (user-fields))))
968 (result (if auth-token
969 (lw2-graphql-query query-string
:auth-token auth-token
)
970 (lw2-graphql-query-timeout-cached query-string
"user-json" user-id
:revalidate revalidate
:force-revalidate force-revalidate
))))
971 (alist-bind ((user-id (or simple-string null
) :--id
)
972 (display-name (or simple-string null
))
973 (full-name (or simple-string null
))
974 (slug (or simple-string null
))
978 (with-cache-transaction
980 (cache-username user-id display-name
))
982 (cache-user-full-name user-id full-name
))
984 (cache-user-slug user-id slug
)
985 (cache-slug-userid slug user-id
))
986 (user-deleted user-id deleted
))))
989 (define-backend-function get-notifications
(&key user-id
(offset 0) (limit 40) auth-token
)
991 (lw2-graphql-query (lw2-query-string :notification
:list
992 (alist* :user-id user-id
:limit limit
:offset offset
*notifications-base-terms
*)
993 :fields
'(:--id
:document-type
:document-id
:link
:title
:message
:type
:viewed
))
994 :auth-token auth-token
))
995 (backend-lw2-modernized
996 (declare (ignore user-id offset limit auth-token
))
997 (let ((*notifications-base-terms
* (remove :null
*notifications-base-terms
* :key
#'cdr
)))
998 (call-next-method))))
1000 (define-backend-function check-notifications
(user-id auth-token
&key full since
)
1002 (multiple-value-bind (notifications user-info
)
1003 (lw2-graphql-query-multi (list
1004 (lw2-query-string* :notification
:list
(alist* :user-id user-id
:limit
(if full
3 1) *notifications-base-terms
*)
1005 :fields
(if full
'(:--id
:message
:created-at
) '(:created-at
)))
1006 (lw2-query-string* :user
:single
(alist :document-id user-id
) :fields
'(:last-notifications-check
)))
1007 :auth-token auth-token
)
1008 (let ((last-check (or since
1009 (let ((last-check-string (cdr (assoc :last-notifications-check user-info
))))
1010 (when (and (stringp last-check-string
) (not (equal last-check-string
"")))
1011 (local-time:parse-timestring last-check-string
))))))
1013 (labels ((unread-p (notification)
1015 (local-time:timestamp
>
1016 (local-time:parse-timestring
(cdr (assoc :created-at notification
)))
1018 ;; User has never checked notifications before -- all are unread
1021 (remove-if-not #'unread-p notifications
)
1022 (unread-p (first notifications
))))))))
1023 (backend-lw2-modernized
1024 (declare (ignore user-id auth-token full since
))
1025 (let ((*notifications-base-terms
* (remove :null
*notifications-base-terms
* :key
#'cdr
)))
1026 (call-next-method))))
1028 (define-cache-database 'backend-lw2-legacy
"comment-reply-by-user")
1030 (define-backend-function mark-comment-replied
(reply)
1032 (alexandria:when-let
* ((parent-comment-id (cdr (assoc :parent-comment-id reply
)))
1033 (reply-id (cdr (assoc :--id reply
)))
1034 (user-id (cdr (assoc :user-id reply
))))
1035 (cache-put "comment-reply-by-user" (concatenate 'string parent-comment-id
" " user-id
) reply-id
))))
1037 (define-backend-function check-comment-replied
(comment-id user-id
)
1039 (cache-get "comment-reply-by-user" (concatenate 'string comment-id
" " user-id
))))
1041 (define-backend-function get-user-page-items
(user-id request-type
&key
(offset 0) (limit 40) (sort-type :date
) drafts
1042 (revalidate *revalidate-default
*) (force-revalidate *force-revalidate-default
*) auth-token
)
1044 (multiple-value-bind (real-offset real-limit
) (if (eq request-type
:both
)
1045 (values 0 (+ offset limit
))
1046 (values offset limit
))
1047 (let* ((cache-database (when (and (eq request-type
:both
)
1048 (or (not offset
) (= offset
0))
1050 (eq sort-type
:date
)
1054 (return-type (if cache-database
:string nil
))
1056 (labels ((posts-query-string ()
1059 (drafts (alist :view
"drafts"))
1060 ((eq sort-type
:score
) (alist :view
"top"))
1061 ((eq sort-type
:date-reverse
) (alist :view
"old"))
1062 (t (alist :view
"userPosts"))))
1063 (terms (alist* :offset real-offset
:limit real-limit
:user-id user-id base-terms
)))
1064 (declare (dynamic-extent base-terms terms
))
1065 (lw2-query-string* :post
:list terms
)))
1066 (comments-query-string ()
1067 (let* ((view (ecase sort-type
1068 (:score
"postCommentsTop")
1069 (:date
"allRecentComments")
1070 (:date-reverse
"postCommentsOld")))
1071 (terms (alist :offset real-offset
1075 (declare (dynamic-extent view terms
))
1076 (lw2-query-string* :comment
:list terms
1078 (declare (dynamic-extent #'posts-query-string
#'comments-query-string
))
1080 (:both
(let ((result (multiple-value-call #'concatenate
'list
1081 (lw2-graphql-query-multi (list (posts-query-string) (comments-query-string))))))
1083 (:string
(json:encode-json-to-string result
))
1085 (:posts
(lw2-graphql-query (format nil
"{~A}" (posts-query-string)) :auth-token auth-token
:return-type return-type
))
1086 (:comments
(lw2-graphql-query (format nil
"{~A}" (comments-query-string)) :auth-token auth-token
:return-type return-type
)))))))
1088 (lw2-graphql-query-timeout-cached fn cache-database user-id
:decoder
'deserialize-query-result
:revalidate revalidate
:force-revalidate force-revalidate
)
1091 (define-backend-function get-conversation-messages
(conversation-id auth-token
)
1093 (lw2-graphql-query-multi
1095 (lw2-query-string* :conversation
:single
(alist :document-id conversation-id
) :fields
'(:title
(:participants
:display-name
:slug
)))
1096 (lw2-query-string* :message
:list
(alist :view
"messagesConversation" :conversation-id conversation-id
) :fields
*messages-index-fields
*))
1097 :auth-token auth-token
)))
1099 (defun search-result-markdown-to-html (item)
1101 (handler-case (nth-value 1 (cl-markdown:markdown
(cdr (assoc :body item
)) :stream nil
))
1102 (serious-condition () "[Error while processing search result]"))
1105 (define-backend-function algolia-search-index-name
(index)
1107 (format nil
"test_~(~A~)" index
))
1109 (format nil
"test_~(~A~)" index
))
1110 (backend-progress-forum
1111 (format nil
"pf-prod-~(~A~)" index
)))
1113 (define-backend-function encode-algolia-search-query
(query indexes
)
1114 (backend-algolia-search
1115 (json:encode-json-alist-to-string
1118 (loop for index in indexes
1119 collect
(alist "indexName" (algolia-search-index-name index
)
1120 "params" (format nil
"query=~A&hitsPerPage=200&page=0"
1121 (url-rewrite:url-encode query
)))))))
1123 (json:encode-json-to-string
1124 (loop for index in indexes
1125 collect
(alist "indexName" (algolia-search-index-name index
)
1126 "params" (alist "query" query
1130 (define-backend-function decode-algolia-search-results
(data)
1131 (backend-algolia-search
1132 (cdr (assoc :results data
)))
1136 (define-backend-function lw2-search-query
(query &key
(indexes '(:tags
:posts
:comments
)))
1137 (backend-algolia-search
1138 (call-with-http-response
1139 (lambda (req-stream)
1141 (result-groups (loop
1142 for results in
(decode-algolia-search-results
1143 (json:decode-json req-stream
))
1144 for index in indexes
1145 for hits
= (cdr (assoc :hits results
))
1146 do
(setf hits
(case index
1147 (:posts
(map 'list
(lambda (post) (if (cdr (assoc :comment-count post
)) post
(alist* :comment-count
0 post
))) hits
))
1148 (:comments
(map 'list
#'search-result-markdown-to-html hits
))
1149 (:tags
(progn (setf tags
(map 'list
(lambda (tag) (alist* :----typename
"Tag" tag
)) hits
))
1154 (with-collector (col)
1155 (let ((remaining-result-groups result-groups
))
1156 (loop while
(some #'identity result-groups
)
1157 do
(multiple-value-bind (firstn rest
)
1158 (firstn (car remaining-result-groups
) 10)
1159 (map nil
#'col firstn
)
1160 (setf (car remaining-result-groups
) rest
1161 remaining-result-groups
(or (rest remaining-result-groups
)
1165 (algolia-search-uri *current-backend
*)
1167 :headers
'(("Origin" .
"https://www.greaterwrong.com")
1168 ("Referer" .
"https://www.greaterwrong.com/")
1169 ("Content-Type" .
"application/json"))
1170 :content
(encode-algolia-search-query query indexes
)
1173 (define-backend-function get-username-wrapper
(user-id fn
)
1175 (funcall fn user-id
))
1176 (backend-lw2-modernized
1177 (if (user-deleted user-id
)
1179 (funcall fn user-id
))))
1181 (define-backend-function get-user-full-name-wrapper
(user-id fn
)
1183 (funcall fn user-id
))
1187 (define-cache-database 'backend-lw2-legacy
"comment-markdown-source" "post-markdown-source")
1189 (defun markdown-source-db-name (target-type)
1190 (ecase target-type
(:comment
"comment-markdown-source") (:post
"post-markdown-source")))
1192 (define-backend-function markdown-source
(target-type id version
)
1193 (backend-lw2-modernized
1194 (let ((db-name (markdown-source-db-name target-type
))
1195 (version (base64:usb8-array-to-base64-string
(hash-string version
))))
1197 (if-let ((cache-data (cache-get db-name id
:value-type
:lisp
)))
1198 (alist-bind ((cached-version simple-string
:version
)
1199 (markdown simple-string
))
1201 (when (string= version cached-version
)
1203 (trivia:ematch
(lw2-graphql-query (lw2-query-string target-type
:single
1204 (alist :document-id id
)
1205 :fields
'(:html-body
(:contents
:markdown
)))
1206 :auth-token
*current-auth-token
*)
1207 ((trivia:alist
(:html-body . html-body
)
1208 (:contents .
(assoc :markdown markdown
)))
1209 (cache-put db-name id
(alist :version
(base64:usb8-array-to-base64-string
(hash-string html-body
)) :markdown markdown
) :value-type
:lisp
)
1212 (define-backend-function (setf markdown-source
) (markdown target-type id version
)
1213 (backend-lw2-modernized
1214 (let ((version (base64:usb8-array-to-base64-string
(hash-string version
))))
1215 (cache-put (markdown-source-db-name target-type
)
1217 (alist :version version
:markdown markdown
)
1218 :value-type
:lisp
))))
1220 (defun get-elicit-question-title (question-id)
1222 (lw2-graphql-query (graphql-query-string "ElicitBlockData" (alist :question-id question-id
) '(:title
)))))
1224 (defun make-rate-limiter (delay)
1225 (let ((rl-hash (make-hash-table :test
'equal
:synchronized t
)))
1227 (let ((unix-time (get-unix-time)))
1228 (if (sb-ext:with-locked-hash-table
(rl-hash)
1229 (maphash (lambda (k v
)
1230 (if (> (- unix-time v
) delay
)
1231 (remhash k rl-hash
)))
1233 (not (gethash datum rl-hash
)))
1235 (setf (gethash datum rl-hash
) unix-time
)
1237 (error "Request aborted due to rate limit."))))))
1239 (defmacro with-rate-limit
(&body outer-body
)
1240 `(let ((rate-limiter (make-rate-limiter 30)))
1241 (macrolet ((rate-limit ((key) &body inner-body
)
1242 `(funcall rate-limiter
,key
(lambda () ,@inner-body
))))
1246 (simple-cacheable ("post-title" 'backend-lw2-legacy
"postid-to-title" post-id
)
1247 (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post
:single
(alist :document-id post-id
) :fields
'(:title
))))))))
1250 (simple-cacheable ("post-slug" 'backend-lw2-legacy
"postid-to-slug" post-id
)
1251 (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post
:single
(alist :document-id post-id
) :fields
'(:slug
))))))))
1254 (simple-cacheable ("slug-postid" 'backend-lw2-legacy
"slug-to-postid" slug
)
1255 (rate-limit (slug) (cdr (first (lw2-graphql-query (lw2-query-string :post
:single
(alist :slug slug
) :fields
'(:--id
))))))))
1258 (simple-cacheable ("username" 'backend-lw2-legacy
"userid-to-displayname" user-id
:get-wrapper
#'get-username-wrapper
)
1259 (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user
:single
(alist :document-id user-id
) :fields
'(:display-name
))))))))
1262 (simple-cacheable ("user-slug" 'backend-lw2-legacy
"userid-to-slug" user-id
)
1263 (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user
:single
(alist :document-id user-id
) :fields
'(:slug
))))))))
1266 (simple-cacheable ("user-full-name" 'backend-lw2-legacy
"userid-to-full-name" user-id
:get-wrapper
#'get-user-full-name-wrapper
)
1267 (rate-limit (user-id) (or (cdr (first (lw2-graphql-query (lw2-query-string :user
:single
(alist :document-id user-id
) :fields
'(:full-name
)))))
1271 (simple-cacheable ("slug-userid" 'backend-lw2-legacy
"slug-to-userid" slug
)
1272 (rate-limit (slug) (cdr (first (lw2-graphql-query (lw2-query-string :user
:single
(alist :slug slug
) :fields
'(:--id
))))))))
1275 (simple-cacheable ("slug-tagid" 'backend-lw2-tags
"slug-to-tagid" slug
:catch-errors nil
)
1276 (rate-limit (slug) (cdr (first (first (lw2-graphql-query (lw2-query-string :tag
:list
(alist :view
"tagBySlug" :slug slug
) :fields
'(:--id
)))))))))
1278 (defun preload-username-cache ()
1279 (declare (optimize space
(compilation-speed 2) (speed 0)))
1280 (let ((user-list (lw2-graphql-query (lw2-query-string :user
:list
'() :fields
'(:--id
:slug
:display-name
)))))
1281 (with-cache-transaction
1282 (loop for user in user-list
1283 do
(alist-bind ((user-id (or simple-string null
) :--id
)
1284 (slug (or simple-string null
))
1285 (display-name (or simple-string null
)))
1289 (cache-username user-id display-name
))
1291 (cache-user-slug user-id slug
)
1292 (cache-slug-userid slug user-id
))))))))