src/backend.lisp

   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*
   9            #:*graphql-uri-hook*
  10            #:*graphql-debug-output*
  11            #:*revalidate-default* #:*force-revalidate-default*
  12            #:*messages-index-fields*
  13            #:*notifications-base-terms*
  14            #:*enable-rate-limit*
  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
  20            #:signal-lw2-errors
  21            #:earliest-post-time
  22            #:flatten-shortform-comments #:get-shortform-votes
  23            #:get-tag-posts
  24            #:get-post-tag-votes #:get-tag-post-votes
  25            #:get-slug-tagid
  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
  30            #:get-collection
  31            #:sequence-post-ids #:get-sequence #:get-post-sequence-ids #:get-sequence-post
  32            #:get-conversation-messages
  33            #:markdown-source
  34            #:get-user
  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
  46              #:*cookie-jar*
  47              #:with-connection-pool #:call-with-connection-pool
  48              #:cache-is-fresh))
  49
  50 (in-package #:lw2.backend)
  51
  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)
  56
  57 (defvar *use-alignment-forum* nil)
  58 (defvar *graphql-uri-hook* #'identity)
  59
  60 (defvar *graphql-debug-output* nil)
  61
  62 (defvar *revalidate-default* t)
  63 (defvar *force-revalidate-default* nil)
  64
  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))
  67
  68 (defparameter *notifications-base-terms* (alist :view "userNotifications" :created-at :null :viewed :null))
  69
  70 (defun request-fields (query-type return-type context)
  71   "Returns the desired fields for a given type of request."
  72   (case return-type
  73     (:total nil)
  74     (t
  75      (with-collector (col)
  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))
  83                         (not graphql-ignore)
  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)
  88                (col
  89                 (let ((result-name (or alias field-name)))
  90                   (if subfields
  91                       (list* result-name subfields)
  92                       result-name)))))))))))
  93
  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))))
  98
  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")
 106
 107 (define-cache-database 'backend-lw2-modernized
 108     "user-deleted")
 109
 110 (define-backend-function comments-list-to-graphql-json (comments-list)
 111   (backend-lw2-legacy
 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)))))))))
 117
 118 (defun do-graphql-debug (query)
 119   (when *graphql-debug-output*
 120     (format *graphql-debug-output* "~&GraphQL query: ~A~%" query)))
 121
 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))
 125        (tagbody ,retry
 126           (labels ((,maybe-retry-fn-name ()
 127                      ,before-maybe-retry
 128                      (when (> ,remaining-retries 0)
 129                        (decf ,remaining-retries)
 130                        ,before-retry
 131                        (go ,retry))))
 132             ,@body)))))
 133
 134 (defun force-close (stream)
 135   (ignore-errors (close stream :abort t)))
 136
 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)
 140
 141 (defun connection-push (dest connection)
 142   (let ((connection-pool *connection-pool*)
 143         old-connection)
 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))))
 151     (when old-connection
 152       (force-close old-connection))))
 153
 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))))))
 160
 161 (defun clear-connection-pool ()
 162   (let ((connection-pool *connection-pool*))
 163     (sb-thread:with-mutex (*connection-pool-lock*)
 164       (maphash
 165        (lambda (dest vector)
 166          (loop for connection across vector
 167                do (force-close connection))
 168          (remhash dest connection-pool))
 169        connection-pool))))
 170
 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))
 178
 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)))
 184       (%make-token-bucket
 185        :base-cost base-cost
 186        :tokens-per-unit tokens-per-unit
 187        :token-limit token-limit
 188        :tokens (round (* token-limit fill-ratio))))))
 189
 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))
 197          (increment 0)
 198          (result nil))
 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)
 203                           (lambda (previous)
 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)
 212                           (lambda (previous)
 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)
 218                                   (min new limit)
 219                                   (max (- limit) (min new-refill limit))))))
 220     result))
 221
 222 (defun parse-ipv4 (string)
 223   (let ((l (map 'list #'parse-integer
 224                 (split-sequence:split-sequence #\. string))))
 225     (loop with res = 0
 226        for n in l
 227        do (setf res (+ n (ash res 8)))
 228        finally (return res))))
 229
 230 (defvar *enable-rate-limit* t)
 231
 232 (defparameter *rate-limit-cost-factor* 1)
 233
 234 (sb-ext:defglobal *global-token-bucket* (make-token-bucket :rate 3 :burst 180))
 235
 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.")))
 239
 240 (defun call-with-http-response (fn uri-string &rest args &key &allow-other-keys)
 241   (when *enable-rate-limit*
 242     (check-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))
 249         (unwind-protect
 250              (handler-bind (((or dex:http-request-failed usocket:ns-condition usocket:socket-condition)
 251                              (lambda (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)
 255                                        (invoke-restart r)
 256                                        (maybe-retry))))))
 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
 262                        new-stream nil))
 263                (when (<= 500 status-code 599)
 264                  (maybe-retry)
 265                  (error 'lw2-connection-error :message (format nil "HTTP status ~A" status-code)))
 266                (setf success t))
 267           (when (not success)
 268             (when (streamp response)
 269               (force-close response))
 270             (when stream
 271               (force-close stream))
 272             (setf stream nil))))
 273       (unwind-protect
 274            (funcall fn response)
 275         (when (streamp response)
 276           (close response))
 277         (when stream ; the connection is reusable
 278           (connection-push uri-dest stream))))))
 279
 280 (defun forwarded-header ()
 281   (let ((addr (and (boundp 'hunchentoot:*request*) (hunchentoot:real-remote-addr))))
 282     (list-cond (addr "X-Forwarded-For" addr))))
 283
 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))
 289                (cond
 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)))))))
 295
 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"))))
 300
 301 (define-backend-function fixup-lw2-return-value (value)
 302   (backend-base
 303    (values value nil))
 304   (backend-lw2-modernized
 305    (values
 306     (let ((x (first value)))
 307       (if (member (car x) '(:result :results :total-count))
 308           (cdr x)
 309           x))
 310     (let ((x (second value)))
 311       (if (eq (car x) :total-count)
 312           (cdr x)))))
 313   (backend-accordius
 314    (values value nil)))
 315
 316 (define-backend-function deserialize-query-result (result-source)
 317   (backend-base
 318    (let ((string-source (typecase result-source
 319                           (string
 320                            result-source)
 321                           (vector
 322                            (flexi-streams:make-in-memory-input-stream result-source))
 323                           (stream
 324                            (ensure-character-stream result-source)))))
 325      (json:decode-json-from-source string-source))))
 326
 327 (define-backend-function postprocess-query-result (result)
 328   (backend-base
 329    result)
 330   (backend-lw2-legacy
 331    (signal-lw2-errors (cdr (assoc :errors result)))
 332    (fixup-lw2-return-value (cdadr (assoc :data result)))))
 333
 334 (define-backend-function decode-query-result (result-source)
 335   (backend-base
 336    (postprocess-query-result
 337     (deserialize-query-result result-source))))
 338
 339 (defmethod graphql-uri ((backend backend-alignment-forum))
 340   (if *use-alignment-forum*
 341       "https://www.alignmentforum.org/graphql"
 342       (call-next-method)))
 343
 344 (define-backend-function backend-request-headers (auth-token forwarded)
 345   (backend-websocket-login
 346    (list-cond* (auth-token :authorization auth-token)
 347                (call-next-method)))
 348   (backend-passport-js-login
 349    (list-cond* (auth-token :cookie (concatenate 'string "loginToken=" auth-token))
 350                (call-next-method)))
 351   (backend-oauth2.0-login
 352    (list-cond* (auth-token :cookie (concatenate 'string "clientId=" (oauth2.0-client-id backend) "; loginToken=" auth-token))
 353                (call-next-method)))
 354   (backend-graphql
 355    (alist* :content-type "application/json"
 356            (if forwarded (forwarded-header)))))
 357
 358 (define-backend-function call-with-backend-response (fn query &key return-type auth-token)
 359   (backend-graphql
 360    (call-with-http-response
 361     fn
 362     (funcall *graphql-uri-hook* (graphql-uri *current-backend*))
 363     :method :post
 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))))
 367
 368 (define-backend-function lw2-graphql-query (query &key auth-token return-type (decoder 'decode-query-result))
 369   (backend-base
 370    (do-graphql-debug query)
 371    (call-with-backend-response
 372     (ecase return-type
 373       ((nil) decoder)
 374       (:string #'identity)
 375       (:both (lambda (string) (values (funcall decoder string) string))))
 376     query
 377     :return-type return-type
 378     :auth-token auth-token)))
 379
 380 (defun lw2-graphql-query-map (fn data &key auth-token postprocess)
 381   (multiple-value-bind (map-values queries)
 382     (loop for d in data
 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)))
 388     (let* ((query-string
 389              (with-output-to-string (stream)
 390                (format stream "{")
 391                (loop for n from 0
 392                      for q in queries
 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)
 398       (values
 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))
 405                 errors))))
 406
 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)))
 409
 410 (defvar *background-cache-update-threads* (make-hash-table :test 'equal
 411                                                            :weakness :value
 412                                                            :synchronized t))
 413
 414 (defvar *parsed-results-cache* (make-hash-table :test 'equal
 415                                                 :weakness :value
 416                                                 :synchronized t))
 417
 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)
 427                            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)
 429         (unless same-data
 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))))))
 433
 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)))))
 441
 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)
 445
 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))))
 453               (values
 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))
 457                      :skip
 458                      (> unmodified-time (* *cache-stale-factor* last-checked-time))))
 459                t
 460                (unix-to-universal-time last-mod)))))))
 461
 462 (defgeneric run-query (query)
 463   (:method ((query string))
 464     (lw2-graphql-query query :return-type :string))
 465   (:method ((query function))
 466     (funcall query)))
 467
 468 (declaim (inline make-thread-with-current-backend))
 469
 470 (defun make-thread-with-current-backend (fn &rest args)
 471   (let ((current-backend *current-backend*))
 472     (apply #'sb-thread:make-thread
 473       (lambda ()
 474         (let ((*current-backend* current-backend))
 475           (funcall fn)))
 476       args)))
 477
 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 ()
 481                (unwind-protect
 482                     (block nil
 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))
 488                         (return error)))
 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*)))
 492                                        (if thread thread
 493                                          (setf (gethash key *background-cache-update-threads*)
 494                                                (make-thread-with-current-backend #'background-fn :name "background cache update"))))))))
 495
 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*))
 498   (backend-base
 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))))
 510            (get-cached-result)
 511            (let ((timeout (if cached-result
 512                               (if force-revalidate nil 0.5)
 513                               nil))
 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))))
 517                    (get-cached-result)
 518                    (handler-bind
 519                        ((fatal-error (lambda (c)
 520                                        (declare (ignore c))
 521                                        (if cached-result
 522                                            (return-from retrieve-result (get-cached-result))))))
 523                      (multiple-value-bind (new-result last-modified)
 524                          (sb-thread:join-thread thread :timeout timeout)
 525                        (typecase new-result
 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))))))))))))))
 531
 532 (define-backend-function lw2-query-string* (query-type return-type args &key context fields with-total))
 533
 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*
 538      (concatenate 'string
 539                   (lisp-to-lw2-case query-type)
 540                   "s"
 541                   (lisp-to-lw2-case return-type))
 542      (if (eq return-type :single)
 543          args
 544          (alist :terms args))
 545      fields)))
 546
 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))))
 556     (case return-type
 557       (:total '(:total-count))
 558       (:list (list-cond (t :results fields)
 559                         (with-total :total-count)))
 560       (:single (alist :result fields)))))
 561
 562 (define-backend-function lw2-query-string (query-type return-type args &key context fields with-total))
 563
 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)))
 567
 568 (define-backend-function lw2-query-list-limit-workaround (query-type terms &rest rest &key fields context auth-token)
 569   (backend-graphql
 570    (declare (ignore fields context))
 571    (let (items-list)
 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))
 578      items-list))
 579   (backend-accordius
 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)))
 582
 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))
 599           (get-cached-result)
 600           (if cached-result
 601               (handler-case
 602                   (query-and-put)
 603                 (t () (get-cached-result)))
 604               (query-and-put))))))
 605
 606 (define-backend-function get-posts-index-query-terms (&key view (sort "new") (limit 40) offset before after karma-threshold &allow-other-keys)
 607   (backend-lw2-legacy
 608    (let ((sort-key (alexandria:switch (sort :test #'string=)
 609                                       ("new" "new")
 610                                       ("hot" "magic")
 611                                       ("active" "recentComments")
 612                                       ("top" "top")
 613                                       ("old" "old"))))
 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"))
 623                             (t (values
 624                                 (alist :sorted-by sort-key :filter "frontpage")
 625                                 (if (not (or (string/= sort "new") (/= limit 40) offset before after karma-threshold))
 626                                     "new-not-meta"))))
 627        (let ((terms
 628               (alist-without-null* :before before
 629                                    :after after
 630                                    ;; Workaround offsets not working as of 2024-02-02
 631                                    :limit (if limit (+ limit (or offset 0)))
 632                                    #| :offset offset |#
 633                                    :karma-threshold karma-threshold
 634                                    view-terms)))
 635          (values terms cache-key))))))
 636
 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)
 639     (if hide-tags
 640         (values (acons :filter-settings (alist :tags (list* :list (map 'list (lambda (tagid) (alist :tag-id tagid :filter-mode "Hidden"))
 641                                                                        hide-tags)))
 642                        query-terms)
 643                 nil)
 644         (values query-terms cache-key))))
 645
 646 (define-backend-function get-posts-index-query-string (&rest args &key &allow-other-keys)
 647   (backend-lw2-legacy
 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)
 652              cache-key))))
 653
 654 (define-backend-function get-posts-index (&rest args &key (limit 40) offset &allow-other-keys)
 655   (backend-lw2-legacy
 656    (declare (dynamic-extent args))
 657    (multiple-value-bind (query-string cache-key)
 658        (apply #'%get-posts-index-query-string backend args)
 659      (if cache-key
 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
 664            (if limit
 665                (subseq* result offset (+ limit offset))
 666                result))))))
 667
 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))
 671   (if hide-tags
 672       (let ((offset (or offset 0)))
 673         (subseq
 674          (apply #'call-next-method backend :offset 0 :limit (+ limit offset) args)
 675          offset))
 676       (call-next-method)))
 677
 678 (defun get-posts-json ()
 679   (lw2-graphql-query (get-posts-index-query-string) :return-type :string))
 680
 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)))
 683
 684 (defun get-recent-comments-json ()
 685   (lw2-graphql-query (lw2-query-string :comment :list '((:view . "allRecentComments") (:limit . 20)) :context :index) :return-type :string))
 686
 687 (defun process-vote-result (res)
 688   (alist-bind ((id (or null simple-string) :--id)
 689                current-user-votes
 690                current-user-vote
 691                current-user-extended-vote)
 692               res
 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)
 697                         id))))
 698
 699 (defun process-votes-result (res)
 700   (let ((hash (make-hash-table)))
 701     (dolist (v res hash)
 702       (multiple-value-bind (vote id) (process-vote-result v)
 703         (when vote
 704           (setf (gethash id hash) vote))))))
 705
 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)))
 710     output))
 711
 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))))
 718
 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)))
 721
 722 (define-cache-database 'backend-lw2-tags "tag-posts" "tag-posts-meta" "post-tags" "post-tags-meta")
 723
 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)
 726   (backend-lw2-tags
 727    (let* ((tagid (get-slug-tagid slug))
 728           (query-fn (lambda ()
 729                       (comments-list-to-graphql-json
 730                        (lw2-query-list-limit-workaround
 731                         :tag-rel
 732                         (alist :view "postsWithTag" :tag-id tagid)
 733                         :fields (list (list* :post (request-fields :post :list :index))))))))
 734      (iter
 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)))
 737         (collect post))))))
 738
 739 (define-backend-function get-tag-post-votes (tag-id auth-token)
 740   (backend-base (progn tag-id auth-token nil))
 741   (backend-lw2-tags
 742    (process-votes-result
 743     (map 'list #'cdr
 744          (lw2-query-list-limit-workaround
 745           :tag-rel
 746           (alist :view "postsWithTag" :tag-id tag-id)
 747           :fields '(:--id :current-user-vote :current-user-extended-vote)
 748           :auth-token auth-token)))))
 749
 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)
 752   (backend-lw2-tags
 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))))
 755
 756 (define-backend-function get-post-tag-votes (post-id auth-token)
 757   (backend-base (progn post-id auth-token nil))
 758   (backend-lw2-tags
 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))))
 762
 763 (define-backend-function get-post-body (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
 764   (backend-graphql
 765    (let ((query-string (lw2-query-string :post :single (alist :document-id post-id) :context :body)))
 766      (block nil
 767        (tagbody retry
 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)
 773                                                          (go retry))))))
 774             (return
 775               (if 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))))))))
 778   (backend-lw2-tags
 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))
 788               post)
 789              (:otherwise
 790               (block nil
 791                 (handler-bind ((error (lambda (condition)
 792                                         (declare (ignore condition))
 793                                         (when hosted-here
 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
 802                         (list-cond*
 803                          ((not hosted-here) :html-body foreign-post-body)
 804                          (t :foreign-post foreign-post)
 805                          post)
 806                         post))))))))))
 807
 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))))
 814
 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
 820                   #'identity
 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)))
 824                           answers)
 825                   :auth-token auth-token)))
 826     (apply #'nconc result)))
 827
 828 (define-backend-function get-post-comments-votes (post-id auth-token)
 829   (backend-graphql
 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))))
 833   (backend-q-and-a
 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
 837       (nconc
 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)
 840        answers)))))
 841
 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))))
 846
 847 (define-backend-function get-post-comments (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
 848   (backend-graphql
 849    (let ((fn (lambda ()
 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)))
 853   (backend-ea-forum
 854    ;; Work around bizarre parent comment bug in EA forum
 855    (declare (ignore revalidate force-revalidate))
 856    (let ((comments (call-next-method)))
 857      (dolist (c comments)
 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))))
 862      comments)))
 863
 864 (defun get-post-answers (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
 865   (let ((fn (lambda ()
 866               (let ((answers (get-post-comments-list post-id "questionAnswers")))
 867                 (comments-list-to-graphql-json
 868                  (nconc
 869                   answers
 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)))
 872
 873 (define-cache-database 'backend-debates
 874     "post-debate-responses-json" "post-debate-responses-json-meta")
 875
 876 (define-backend-function get-post-debate-responses (post-id &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*))
 877   (backend-base
 878    (declare (ignore post-id revalidate force-revalidate))
 879    nil)
 880   (backend-debates
 881    (let ((fn (lambda ()
 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))))
 885
 886 (define-backend-function get-collection (collection-id)
 887   (backend-graphql
 888    (lw2-graphql-query
 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))))))))))
 895
 896 (defun sequence-iterate (sequence fn)
 897   (dolist (chapter (cdr (assoc :chapters sequence)))
 898     (dolist (post (cdr (assoc :posts chapter)))
 899       (funcall fn post))))
 900
 901 (defun sequence-post-ids (sequence)
 902   (with-collector (col)
 903     (sequence-iterate sequence
 904                       (lambda (post)
 905                         (col (cdr (assoc :--id post)))))
 906     (col)))
 907
 908 (defun get-sequence-post (sequence post-id)
 909   (sequence-iterate sequence
 910                     (lambda (post)
 911                       (when (string= (cdr (assoc :--id post)) post-id)
 912                         (return-from get-sequence-post post))))
 913   nil)
 914
 915 (define-backend-function get-sequence (sequence-id)
 916   (backend-graphql
 917    (let ((fn (lambda ()
 918                (multiple-value-bind (sequence sequence-json)
 919                    (lw2-graphql-query
 920                     (lw2-query-string :sequence :single
 921                                       (alist :document-id sequence-id)
 922                                       :fields `(:--id :title :created-at :user-id
 923                                                       (:contents :html)
 924                                                       (:chapters :title :subtitle :number (:contents :html) (:posts ,@(request-fields :post :list nil)))
 925                                                       :grid-image-id :----typename))
 926                     :return-type :both)
 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)))))
 933                    sequence-json)))))
 934      (lw2-graphql-query-timeout-cached fn "sequence-json" sequence-id))))
 935
 936 (define-backend-function get-post-sequence-ids (post-id)
 937   (backend-graphql
 938    (cache-get "post-sequence" post-id :value-type :json)))
 939
 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)))
 948   (values))
 949
 950 (define-backend-function user-deleted (user-id &optional (status nil set))
 951   (backend-base
 952    (declare (ignore user-id status set))
 953    nil)
 954   (backend-lw2-modernized
 955    (when user-id
 956      (if set
 957          (if status
 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)))))
 961
 962 (define-backend-function get-user (user-identifier-type user-identifier &key (revalidate *revalidate-default*) (force-revalidate *force-revalidate-default*) auth-token)
 963   (backend-graphql
 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))
 975                   (deleted boolean))
 976                  result
 977                  (when user-id
 978          (with-cache-transaction
 979            (when display-name
 980              (cache-username user-id display-name))
 981            (when full-name
 982              (cache-user-full-name user-id full-name))
 983            (when slug
 984              (cache-user-slug user-id slug)
 985              (cache-slug-userid slug user-id))
 986            (user-deleted user-id deleted))))
 987      result)))
 988
 989 (define-backend-function get-notifications (&key user-id (offset 0) (limit 40) auth-token)
 990   (backend-lw2-legacy
 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))))
 999
1000 (define-backend-function check-notifications (user-id auth-token &key full since)
1001   (backend-lw2-legacy
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))))))
1012        (when notifications
1013          (labels ((unread-p (notification)
1014                     (if last-check
1015                         (local-time:timestamp>
1016                          (local-time:parse-timestring (cdr (assoc :created-at notification)))
1017                          last-check)
1018                         ;; User has never checked notifications before -- all are unread
1019                         t)))
1020            (if full
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))))
1027
1028 (define-cache-database 'backend-lw2-legacy "comment-reply-by-user")
1029
1030 (define-backend-function mark-comment-replied (reply)
1031   (backend-lw2-legacy
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))))
1036
1037 (define-backend-function check-comment-replied (comment-id user-id)
1038   (backend-lw2-legacy
1039    (cache-get "comment-reply-by-user" (concatenate 'string comment-id " " user-id))))
1040
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)
1043   (backend-lw2-legacy
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))
1049                                        (= limit 40)
1050                                        (eq sort-type :date)
1051                                        (not drafts)
1052                                        (not auth-token))
1053                               "user-page-items"))
1054             (return-type (if cache-database :string nil))
1055             (fn (lambda ()
1056                   (labels ((posts-query-string ()
1057                              (let* ((base-terms
1058                                      (cond
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
1072                                                   :limit real-limit
1073                                                   :user-id user-id
1074                                                   :view view)))
1075                                (declare (dynamic-extent view terms))
1076                                (lw2-query-string* :comment :list terms
1077                                                   :context :index))))
1078                     (declare (dynamic-extent #'posts-query-string #'comments-query-string))
1079                     (case request-type
1080                       (:both (let ((result (multiple-value-call #'concatenate 'list
1081                                                                 (lw2-graphql-query-multi (list (posts-query-string) (comments-query-string))))))
1082                                (ecase return-type
1083                                  (:string (json:encode-json-to-string result))
1084                                  ((nil) 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)))))))
1087        (if cache-database
1088            (lw2-graphql-query-timeout-cached fn cache-database user-id :decoder 'deserialize-query-result :revalidate revalidate :force-revalidate force-revalidate)
1089            (funcall fn))))))
1090
1091 (define-backend-function get-conversation-messages (conversation-id auth-token)
1092   (backend-lw2-legacy
1093    (lw2-graphql-query-multi
1094     (list
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)))
1098
1099 (defun search-result-markdown-to-html (item)
1100   (alist* :html-body
1101           (handler-case (nth-value 1 (cl-markdown:markdown (cdr (assoc :body item)) :stream nil))
1102             (serious-condition () "[Error while processing search result]"))
1103           item))
1104
1105 (define-backend-function algolia-search-index-name (index)
1106   (backend-lw2
1107    (format nil "test_~(~A~)" index))
1108   (backend-ea-forum
1109    (format nil "test_~(~A~)" index))
1110   (backend-progress-forum
1111    (format nil "pf-prod-~(~A~)" index)))
1112
1113 (define-backend-function encode-algolia-search-query (query indexes)
1114   (backend-algolia-search
1115    (json:encode-json-alist-to-string
1116     (alist
1117      "requests"
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)))))))
1122   (backend-lw2
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
1127                                          "hitsPerPage" 200
1128                                          "page" 0))))))
1129
1130 (define-backend-function decode-algolia-search-results (data)
1131   (backend-algolia-search
1132    (cdr (assoc :results data)))
1133   (backend-lw2
1134    data))
1135
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)
1140       (let* ((tags nil)
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))
1150                                                                 nil))
1151                                                   (t hits)))
1152                                   collect hits)))
1153         (values
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)
1162                                                        result-groups)))))
1163            (col))
1164          tags)))
1165     (algolia-search-uri *current-backend*)
1166     :method :post
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)
1171     :want-stream t)))
1172
1173 (define-backend-function get-username-wrapper (user-id fn)
1174   (backend-base
1175    (funcall fn user-id))
1176   (backend-lw2-modernized
1177    (if (user-deleted user-id)
1178        "[deleted]"
1179        (funcall fn user-id))))
1180
1181 (define-backend-function get-user-full-name-wrapper (user-id fn)
1182   (backend-base
1183    (funcall fn user-id))
1184   (backend-ea-forum
1185    ""))
1186
1187 (define-cache-database 'backend-lw2-legacy "comment-markdown-source" "post-markdown-source")
1188
1189 (defun markdown-source-db-name (target-type)
1190   (ecase target-type (:comment "comment-markdown-source") (:post "post-markdown-source")))
1191
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))))
1196      (or
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))
1200                           cache-data
1201                           (when (string= version cached-version)
1202                             markdown)))
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)
1210                       markdown))))))
1211
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)
1216                 id
1217                 (alist :version version :markdown markdown)
1218                 :value-type :lisp))))
1219
1220 (defun get-elicit-question-title (question-id)
1221   (cdr
1222    (lw2-graphql-query (graphql-query-string "ElicitBlockData" (alist :question-id question-id) '(:title)))))
1223
1224 (defun make-rate-limiter (delay)
1225   (let ((rl-hash (make-hash-table :test 'equal :synchronized t)))
1226     (lambda (datum fn)
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)))
1232                        rl-hash)
1233               (not (gethash datum rl-hash)))
1234             (progn
1235               (setf (gethash datum rl-hash) unix-time)
1236               (funcall fn))
1237             (error "Request aborted due to rate limit."))))))
1238
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))))
1243          ,@outer-body)))
1244
1245 (with-rate-limit
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))))))))
1248
1249 (with-rate-limit
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))))))))
1252
1253 (with-rate-limit
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))))))))
1256
1257 (with-rate-limit
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))))))))
1260
1261 (with-rate-limit
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))))))))
1264
1265 (with-rate-limit
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)))))
1268                               ""))))
1269
1270 (with-rate-limit
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))))))))
1273
1274 (with-rate-limit
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)))))))))
1277
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)))
1286                           user
1287                 (when user-id
1288                   (when display-name
1289                     (cache-username user-id display-name))
1290                   (when slug
1291                     (cache-user-slug user-id slug)
1292                     (cache-slug-userid slug user-id))))))))