src/backend.lisp

   1 (uiop:define-package #:lw2.backend
   2   (:use #:cl #:sb-thread #:flexi-streams #:alexandria #:lw2-viewer.config #:lw2.sites #:lw2.context #:lw2.graphql #:lw2.lmdb #:lw2.utils #:lw2.hash-utils #:lw2.backend-modules)
   3   (:reexport #:lw2.backend-modules)
   4   (:export #:*graphql-debug-output*
   5            #:posts-index-fields #:*messages-index-fields*
   6            #:comments-index-fields
   7            #:*notifications-base-terms*
   8            #:condition-http-return-code
   9            #:lw2-error #:lw2-client-error #:lw2-not-found-error #:lw2-user-not-found-error #:lw2-not-allowed-error #:lw2-server-error #:lw2-connection-error #:lw2-unknown-error
  10            #:log-condition #:log-conditions #:start-background-loader #:stop-background-loader #:background-loader-running-p
  11            #:lw2-graphql-query-streamparse #:lw2-graphql-query-noparse #:decode-graphql-json #:lw2-graphql-query
  12            #:lw2-query-string* #:lw2-query-string
  13            #:lw2-graphql-query-map #:lw2-graphql-query-multi
  14            #:get-posts-index #:get-posts-json #:get-post-body #:get-post-vote #:get-post-comments #:get-post-answers #:get-post-comments-votes #:get-recent-comments #:get-recent-comments-json
  15            #:get-notifications #:check-notifications
  16            #:lw2-search-query #:get-post-title #:get-post-slug #:get-slug-postid #:get-username #:get-user-slug)
  17   (:recycle #:lw2-viewer)
  18   (:unintern #:get-posts #:make-posts-list-query))
  19
  20 (in-package #:lw2.backend)
  21
  22 (defvar *cookie-jar* (make-instance 'drakma:cookie-jar))
  23
  24 (defvar *graphql-debug-output* nil)
  25
  26 (defparameter *posts-index-fields* '(:title :--id :slug :user-id :posted-at :base-score :comment-count :page-url :url :word-count :frontpage-date :curated-date :meta :draft :af :vote-count))
  27 (defparameter *comments-index-fields* '(:--id :user-id :post-id :posted-at :parent-comment-id (:parent-comment :--id :user-id :post-id) :base-score :page-url :vote-count :retracted :deleted-public :html-body))
  28 (defparameter *post-comments-fields* '(:--id :user-id :post-id :posted-at :parent-comment-id :base-score :page-url :vote-count :retracted :deleted-public :html-body))
  29 (defparameter *messages-index-fields* '(:--id :user-id :created-at :content (:conversation :--id :title) :----typename))
  30
  31 (defparameter *notifications-base-terms* (alist :view "userNotifications" :created-at :null :viewed :null))
  32
  33 (defmacro define-backend-fields ())
  34
  35 (define-backend-function posts-index-fields ()
  36   (backend-graphql (load-time-value *posts-index-fields*))
  37   (backend-q-and-a (load-time-value (append *posts-index-fields* '(:question)))))
  38
  39 (define-backend-function comments-index-fields ()
  40   (backend-graphql (load-time-value *comments-index-fields*))
  41   (backend-q-and-a (load-time-value (append *comments-index-fields* '(:answer :parent-answer-id)))))
  42
  43 (define-backend-function post-comments-fields ()
  44   (backend-graphql (load-time-value *post-comments-fields*))
  45   (backend-q-and-a (load-time-value (append *post-comments-fields* '(:answer :parent-answer-id)))))
  46
  47 (define-cache-database "index-json" "post-comments-json" "post-comments-json-meta" "post-answers-json" "post-answers-json-meta" "post-body-json" "post-body-json-meta")
  48
  49 (defmethod condition-http-return-code ((c condition)) 500)
  50
  51 (define-condition lw2-error (error) ((http-return-code :allocation :class :reader condition-http-return-code :initform 503)))
  52
  53 (define-condition lw2-client-error (lw2-error) ((http-return-code :allocation :class :initform 400)))
  54
  55 (define-condition lw2-not-found-error (lw2-client-error) ((http-return-code :allocation :class :initform 404))
  56   (:report "LW server reports: document not found."))
  57
  58 (define-condition lw2-user-not-found-error (lw2-not-found-error) ()
  59   (:report "User not found."))
  60
  61 (define-condition lw2-not-allowed-error (lw2-client-error) ((http-return-code :allocation :class :initform 403))
  62   (:report "LW server reports: not allowed."))
  63
  64 (define-condition lw2-server-error (lw2-error) ())
  65
  66 (define-condition lw2-connection-error (lw2-server-error)
  67   ((message :initarg :message :reader lw2-server-error-message))
  68   (:report (lambda (c s)
  69              (format s "Unable to connect to LW server: ~A" (lw2-server-error-message c)))))
  70
  71 (define-condition lw2-unknown-error (lw2-server-error)
  72   ((message :initarg :message :reader lw2-unknown-error-message))
  73   (:report (lambda (c s)
  74              (format s "Unrecognized LW server error: ~A" (lw2-unknown-error-message c)))))
  75
  76 (defun log-condition (condition)
  77   (with-open-file (outstream "./logs/error.log" :direction :output :if-exists :append :if-does-not-exist :create)
  78     (format outstream "~%~A: ~S ~A~%" (local-time:format-timestring nil (local-time:now)) condition condition)
  79     (sb-debug:print-backtrace :stream outstream :from :interrupted-frame :print-frame-source t)))
  80
  81 (defmacro log-conditions (&body body)
  82   `(block log-conditions
  83      (handler-bind
  84        (((or warning serious-condition) (lambda (c) (log-condition c))))
  85        (progn ,@body))))
  86
  87 (define-backend-function comments-list-to-graphql-json (comments-list)
  88   (backend-lw2-legacy
  89    (json:encode-json-to-string
  90     (json:with-local-class-registry ()
  91       (json:make-object `((data . ,(json:make-object `((*comments-list . ,comments-list)) nil))) nil))))
  92   (backend-lw2-modernized
  93    (json:encode-json-to-string
  94     (json:with-local-class-registry ()
  95       (json:make-object `((data . ,(json:make-object `((*comments-list . ,(json:make-object `((results . ,comments-list)) nil))) nil))) nil)))))
  96
  97 (defvar *background-loader-thread* nil)
  98 (defvar *background-loader-semaphore* (make-semaphore :count 1))
  99 (defvar *background-loader-ready* nil)
 100
 101 (defun background-loader-running-p ()
 102   (case (semaphore-count *background-loader-semaphore*)
 103     (0 t)
 104     (1 nil)))
 105
 106 (defun background-loader-ready-p ()
 107   (and (background-loader-running-p)
 108        (background-loader-enabled *current-site*)
 109        *background-loader-ready*))
 110
 111 (defun make-site-background-loader-fn (site)
 112   (let (last-comment-processed)
 113     (lambda ()
 114       (with-site-context (site)
 115         (handler-case
 116             (log-conditions
 117              (let ((posts-json (sb-sys:with-deadline (:seconds 120) (get-posts-json))))
 118                (when (and posts-json (ignore-errors (json:decode-json-from-string posts-json)))
 119                  (cache-put "index-json" "new-not-meta" posts-json)
 120                  (let ((posts-list (decode-graphql-json posts-json)))
 121                    (with-db (db "postid-to-title")
 122                      (dolist (post posts-list)
 123                        (lmdb-put-string db (cdr (assoc :--id post)) (cdr (assoc :title post)))))
 124                    (with-db (db "postid-to-slug")
 125                      (dolist (post posts-list)
 126                        (lmdb-put-string db (cdr (assoc :--id post)) (cdr (assoc :slug post)))))))))
 127           (t (condition) (values nil condition)))
 128         (handler-case
 129             (log-conditions
 130              (let ((recent-comments-json (sb-sys:with-deadline (:seconds 120) (get-recent-comments-json))))
 131                (when-let (recent-comments (ignore-errors (decode-graphql-json recent-comments-json)))
 132                          (cache-put "index-json" "recent-comments" recent-comments-json)
 133                          (loop for comment in recent-comments
 134                             as comment-id = (cdr (assoc :--id comment))
 135                             as cache-database = (if (or (cdr (assoc :answer comment)) (cdr (assoc :parent-answer-id comment)))
 136                                                     "post-answers-json"
 137                                                     "post-comments-json")
 138                             if (string= comment-id last-comment-processed) return nil
 139                             do
 140                               (with-cache-transaction
 141                                   (let* ((post-id (cdr (assoc :post-id comment)))
 142                                          (post-comments (ignore-errors (decode-graphql-json (cache-get cache-database post-id))))
 143                                          (new-post-comments (sort (cons comment (delete-if (lambda (c) (string= comment-id (cdr (assoc :--id c)))) post-comments))
 144                                                                   #'> :key (lambda (c) (cdr (assoc :base-score c))))))
 145                                     (cache-update cache-database post-id (comments-list-to-graphql-json new-post-comments)))))
 146                          (setf last-comment-processed (cdr (assoc :--id (first recent-comments)))))))
 147           (t (condition) (values nil condition)))))))
 148
 149 (defun background-loader ()
 150   (let (sites loader-functions)
 151     (loop
 152        (unless (eq sites *sites*)
 153          (setf sites *sites*
 154                loader-functions (loop for site in sites
 155                                    when (background-loader-enabled site)
 156                                    collect (make-site-background-loader-fn site))))
 157        (dolist (loader-fn loader-functions)
 158          (funcall loader-fn))
 159        (setf *background-loader-ready* t)
 160        (if (wait-on-semaphore *background-loader-semaphore* :timeout 60)
 161            (return)))))
 162
 163 (defun start-background-loader ()
 164   (if (background-loader-running-p)
 165       (warn "Background loader already running.")
 166       (progn
 167         (wait-on-semaphore *background-loader-semaphore*)
 168         (setf *background-loader-thread* (sb-thread:make-thread #'background-loader)))))
 169
 170 (defun stop-background-loader ()
 171   (if (background-loader-running-p)
 172       (progn
 173         (signal-semaphore *background-loader-semaphore*)
 174         (join-thread *background-loader-thread*)
 175         (setf *background-loader-thread* nil
 176               *background-loader-ready* nil)
 177         (signal-semaphore *background-loader-semaphore*))
 178       (warn "Background loader not running.")))
 179
 180 (defun do-graphql-debug (query)
 181   (when *graphql-debug-output*
 182     (format *graphql-debug-output* "~&GraphQL query: ~A~%" query)))
 183
 184 (defun lw2-graphql-query-streamparse (query &key auth-token)
 185   (do-graphql-debug query)
 186   (multiple-value-bind (req-stream status-code headers final-uri reuse-stream want-close)
 187     (drakma:http-request (graphql-uri *current-backend*) :parameters (list (cons "query" query))
 188                          :cookie-jar *cookie-jar* :additional-headers (if auth-token `(("authorization" . ,auth-token)) nil)
 189                          :want-stream t :close t)
 190     (declare (ignore status-code headers final-uri reuse-stream))
 191     (setf (flexi-stream-external-format req-stream) :utf-8)
 192     (unwind-protect
 193       (json:decode-json req-stream)
 194       (if want-close (close req-stream)))))
 195
 196 (defun lw2-graphql-query-noparse (query &key auth-token)
 197   (do-graphql-debug query)
 198   (multiple-value-bind (response-body status-code headers final-uri reuse-stream want-close status-string)
 199     (drakma:http-request (graphql-uri *current-backend*) :parameters (list (cons "query" query))
 200                          :cookie-jar *cookie-jar* :additional-headers (if auth-token `(("authorization" . ,auth-token)) nil)
 201                          :want-stream nil :close t)
 202     (declare (ignore headers final-uri reuse-stream want-close))
 203     (cond
 204       ((= status-code 200)
 205        (octets-to-string response-body :external-format :utf-8))
 206       ((= status-code 400)
 207        (decode-graphql-json (octets-to-string response-body :external-format :utf-8)))
 208       (t
 209         (error "Error while contacting LW2: ~A ~A" status-code status-string)))))
 210
 211 (defun signal-lw2-errors (errors)
 212   (loop for error in errors
 213         do (let ((message (cdr (assoc :message error)))
 214                  (path (cdr (assoc :path error))))
 215              (unless (and path (> (length path) 1))
 216                (cond
 217                  ((search "document_not_found" message) (error (make-condition 'lw2-not-found-error)))
 218                  ((search "not_allowed" message) (error (make-condition 'lw2-not-allowed-error)))
 219                  (t (error (make-condition 'lw2-unknown-error :message message))))))))
 220
 221 (define-backend-function fixup-lw2-return-value (value)
 222   (backend-lw2-legacy
 223    value)
 224   (backend-lw2-modernized
 225    (values-list
 226     (map 'list
 227          (lambda (x)
 228            (if (member (car x) '(:result :results :total-count))
 229                (cdr x)
 230                x))
 231          value))))
 232
 233 (defun decode-graphql-json (json-string)
 234   (let* ((decoded (json:decode-json-from-string json-string))
 235          (errors (cdr (assoc :errors decoded))))
 236     (signal-lw2-errors errors)
 237     (fixup-lw2-return-value (cdadr (assoc :data decoded)))))
 238
 239 (defun lw2-graphql-query-map (fn data &key auth-token postprocess)
 240   (multiple-value-bind (map-values queries)
 241     (loop for d in data
 242           as out-values = (multiple-value-list (funcall fn d))
 243           as (out passthrough-p) = out-values
 244           collect out-values into map-values
 245           when (not passthrough-p) collect out into queries
 246           finally (return (values map-values queries)))
 247     (let* ((query-string
 248              (with-output-to-string (stream)
 249                (format stream "{")
 250                (loop for n from 0
 251                      for q in queries
 252                      do (format stream "g~6,'0D:~A " n q))
 253                (format stream "}")))
 254            (query-result-data (when queries (lw2-graphql-query-streamparse query-string :auth-token auth-token)))
 255            (errors (cdr (assoc :errors query-result-data))))
 256       (signal-lw2-errors errors)
 257       (values
 258         (loop as results = (sort (cdr (assoc :data query-result-data)) #'string< :key #'car) then (if passthrough-p results (rest results))
 259               for (out passthrough-p) in map-values
 260               as result-data-cell = (first results)
 261                       as result-data = (if passthrough-p out (fixup-lw2-return-value (cdr result-data-cell)))
 262                       for input-data in data
 263                       collect (if postprocess (funcall postprocess input-data result-data) result-data))
 264                 errors))))
 265
 266 (defun lw2-graphql-query-multi (query-list &key auth-token)
 267   (values-list (lw2-graphql-query-map #'identity query-list :auth-token auth-token)))
 268
 269 (defun lw2-graphql-query (query &key auth-token)
 270   (decode-graphql-json (lw2-graphql-query-noparse query :auth-token auth-token)))
 271
 272 (defvar *background-cache-update-threads* (make-hash-table :test 'equal
 273                                                            :weakness :value
 274                                                            :synchronized t))
 275
 276 (defun cache-update (cache-db key data)
 277   (let ((meta-db (format nil "~A-meta" cache-db))
 278         (new-hash (hash-string data))
 279         (current-time (get-unix-time)))
 280     (with-cache-transaction
 281       (let* ((metadata (if-let (m-str (cache-get meta-db key)) (read-from-string m-str)))
 282              (last-mod (if (equalp new-hash (cdr (assoc :city-128-hash metadata)))
 283                            (or (cdr (assoc :last-modified metadata)) current-time)
 284                            current-time)))
 285         (cache-put meta-db key (prin1-to-string `((:last-checked . ,current-time) (:last-modified . ,last-mod) (:city-128-hash . ,new-hash))))
 286         (cache-put cache-db key data)))))
 287
 288 (declaim (type (and fixnum (integer 1)) *cache-stale-factor*))
 289 (defparameter *cache-stale-factor* 20)
 290
 291 (defun cache-is-fresh (cache-db key)
 292   (let ((metadata (if-let (m-str (cache-get (format nil "~A-meta" cache-db) key)) (read-from-string m-str)))
 293         (current-time (get-unix-time)))
 294     (if-let ((last-mod (cdr (assoc :last-modified metadata)))
 295              (last-checked (cdr (assoc :last-checked metadata))))
 296             (> (- last-checked last-mod) (* *cache-stale-factor* (- current-time last-checked))))))
 297
 298 (defun run-query (query)
 299   (etypecase query
 300     (string (lw2-graphql-query-noparse query))
 301     (function (funcall query))))
 302
 303 (declaim (inline make-thread-with-current-backend))
 304
 305 (defun make-thread-with-current-backend (fn &rest args)
 306   (let ((current-backend *current-backend*))
 307     (apply #'sb-thread:make-thread
 308       (lambda ()
 309         (let ((*current-backend* current-backend))
 310           (funcall fn)))
 311       args)))
 312
 313 (defun ensure-cache-update-thread (query cache-db cache-key)
 314   (let ((key (format nil "~A-~A" cache-db cache-key)))
 315     (labels ((background-fn ()
 316                             (handler-case
 317                               (prog1
 318                                 (cache-update cache-db cache-key (run-query query))
 319                                 (remhash key *background-cache-update-threads*))
 320                               (t (c)
 321                                  (remhash key *background-cache-update-threads*)
 322                                  (log-condition c)
 323                                  (sb-thread:abort-thread)))))
 324       (sb-ext:with-locked-hash-table (*background-cache-update-threads*)
 325                                      (let ((thread (gethash key *background-cache-update-threads*)))
 326                                        (if thread thread
 327                                          (setf (gethash key *background-cache-update-threads*)
 328                                                (make-thread-with-current-backend #'background-fn))))))))
 329
 330 (defun lw2-graphql-query-timeout-cached (query cache-db cache-key &key (revalidate t) force-revalidate)
 331     (multiple-value-bind (cached-result is-fresh) (with-cache-readonly-transaction (values (cache-get cache-db cache-key) (cache-is-fresh cache-db cache-key)))
 332       (if (and cached-result (if force-revalidate (not revalidate) (or is-fresh (not revalidate))))
 333           (decode-graphql-json cached-result)
 334           (let ((timeout (if cached-result (if force-revalidate nil 3) nil))
 335                 (thread (ensure-cache-update-thread query cache-db cache-key)))
 336             (decode-graphql-json
 337               (handler-case
 338                 (sb-thread:join-thread thread :timeout timeout)
 339                 (t () (or cached-result
 340                           (error "Failed to load ~A ~A and no cached version available." cache-db cache-key)))))))))
 341
 342 (define-backend-function lw2-query-string* (query-type return-type args fields &key with-total))
 343
 344 (define-backend-operation lw2-query-string* backend-lw2-legacy (query-type return-type args fields &key with-total)
 345   (declare (ignore with-total))
 346   (graphql-query-string*
 347     (concatenate 'string (string-capitalize query-type)
 348                          "s"
 349                          (string-capitalize return-type))
 350     (if (eq return-type :single)
 351         args
 352         (alist :terms args))
 353     fields))
 354
 355 (define-backend-operation lw2-query-string* backend-lw2-modernized (query-type return-type args fields &key with-total)
 356   (graphql-query-string*
 357     (if (eq return-type :single)
 358         (string-downcase query-type)
 359         (concatenate 'string (string-downcase query-type) "s"))
 360     (alist :input (case return-type
 361                       (:single (alist :selector args))
 362                       (:list (alist :enable-total with-total :terms args))
 363                       (:total (alist :enable-total t :terms args))))
 364     (case return-type
 365         (:total '(:total-count))
 366         (:list (nconc (list (cons :results fields)) (if with-total '(:total-count))))
 367         (:single (list (cons :result fields))))))
 368
 369 (define-backend-function lw2-query-string (query-type return-type args fields &key with-total))
 370
 371 (define-backend-operation lw2-query-string backend-lw2-legacy (query-type return-type args fields &key with-total)
 372   (format nil "{~A}" (lw2-query-string* query-type return-type args fields :with-total with-total)))
 373
 374 (defun get-cached-index-query (cache-id query)
 375   (labels ((query-and-put ()
 376              (let* ((result (lw2-graphql-query-noparse query))
 377                     (decoded-result (multiple-value-list (decode-graphql-json result))))
 378                (cache-put "index-json" cache-id result)
 379                (values-list decoded-result))))
 380     (let ((cached-result (cache-get "index-json" cache-id)))
 381       (if (and cached-result (background-loader-ready-p))
 382         (decode-graphql-json cached-result)
 383         (if cached-result
 384             (handler-case
 385               (query-and-put)
 386               (t () (decode-graphql-json cached-result)))
 387             (query-and-put))))))
 388
 389 (define-backend-function get-posts-index-query-string (&key view (sort "new") (limit 20) offset before after)
 390   (backend-lw2-legacy
 391    (multiple-value-bind (view-terms cache-key)
 392     (alexandria:switch (view :test #'string=)
 393                        ("featured" (alist :view "curated"))
 394                        ("all" (alist :view (if (string= sort "hot") "community" "new") :meta :null))
 395                        ("meta" (alist :view "new" :meta t :all t))
 396                        ("community" (alist :view "new" :meta t :all t))
 397                        ("alignment-forum" (alist :view "new" :af t))
 398                        ("questions" (alist :view "questions"))
 399                        (t (values (alist :view (if (string= sort "hot") "frontpage" "frontpage-rss")) (if (not (or (string/= sort "new") (/= limit 20) offset before after)) "new-not-meta"))))
 400     (let* ((extra-terms
 401              (remove-if (lambda (x) (null (cdr x)))
 402                         (alist :before before :after after :limit limit :offset offset)))
 403            (query-string (lw2-query-string :post :list (nconc view-terms extra-terms) (posts-index-fields))))
 404       (values query-string cache-key)))))
 405
 406 (define-backend-function get-posts-index (&rest args &key &allow-other-keys)
 407   (backend-lw2-legacy
 408    (declare (dynamic-extent args))
 409    (multiple-value-bind (query-string cache-key)
 410        (apply #'%get-posts-index-query-string (list* backend args))
 411      (if cache-key
 412          (get-cached-index-query cache-key query-string)
 413          (lw2-graphql-query query-string)))))
 414
 415 (defun get-posts-json ()
 416   (lw2-graphql-query-noparse (get-posts-index-query-string)))
 417
 418 (defun get-recent-comments (&key with-total)
 419   (get-cached-index-query "recent-comments" (lw2-query-string :comment :list '((:view . "recentComments") (:limit . 20)) (comments-index-fields) :with-total with-total)))
 420
 421 (defun get-recent-comments-json ()
 422   (lw2-graphql-query-noparse (lw2-query-string :comment :list '((:view . "recentComments") (:limit . 20)) (comments-index-fields))))
 423
 424 (defun process-vote-result (res)
 425   (let ((id (cdr (assoc :--id res)))
 426         (votetype (cdr (assoc :vote-type (first (cdr (assoc :current-user-votes res)))))))
 427     (values votetype id)))
 428
 429 (defun process-votes-result (res)
 430   (loop for v in res
 431         collect (multiple-value-bind (votetype id) (process-vote-result v) (cons id votetype))))
 432
 433 (defun get-post-vote (post-id auth-token)
 434   (process-vote-result (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) '(:--id (:current-user-votes :vote-type))) :auth-token auth-token)))
 435
 436 (define-backend-function get-post-body (post-id &key (revalidate t) force-revalidate auth-token)
 437   (backend-graphql
 438    (let ((query-string (lw2-query-string :post :single (alist :document-id post-id) (cons :html-body (posts-index-fields)))))
 439      (if auth-token
 440          (lw2-graphql-query query-string :auth-token auth-token)
 441          (lw2-graphql-query-timeout-cached query-string "post-body-json" post-id :revalidate revalidate :force-revalidate force-revalidate)))))
 442
 443 (define-backend-function lw2-query-list-limit-workaround (query-type terms fields &key auth-token)
 444   (backend-graphql
 445    (let (items-list)
 446      (loop for offset from 0 by 500
 447         as items-next = (lw2-graphql-query (lw2-query-string query-type :list (nconc (alist :limit 500 :offset offset) terms) fields)
 448                                            :auth-token auth-token)
 449         while items-next
 450         do (setf items-list (nconc items-list items-next)))
 451      items-list))
 452   (backend-accordius
 453    (lw2-graphql-query (lw2-query-string query-type :list terms fields) :auth-token auth-token)))
 454
 455 (defun get-post-comments-list (post-id view &key auth-token parent-answer-id (fields (post-comments-fields)))
 456   (let ((terms (alist :view view :post-id post-id)))
 457     (when parent-answer-id
 458       (setf terms (acons :parent-answer-id parent-answer-id terms)))
 459     (lw2-query-list-limit-workaround :comment terms fields :auth-token auth-token)))
 460
 461 (define-backend-function get-post-comments-votes (post-id auth-token)
 462   (backend-graphql
 463    (let ((fields '(:--id (:current-user-votes :vote-type))))
 464      (get-post-comments-list post-id "postCommentsTop" :auth-token auth-token :fields fields)))
 465   (backend-q-and-a
 466    (let* ((fields '(:--id (:current-user-votes :vote-type)))
 467           (answers (get-post-comments-list post-id "questionAnswers" :auth-token auth-token :fields fields)))
 468      (process-votes-result
 469       (nconc
 470        (get-post-comments-list post-id "postCommentsTop" :auth-token auth-token :fields fields)
 471        (loop
 472           for a in answers
 473           nconc (get-post-comments-list post-id "repliesToAnswer" :parent-answer-id (cdr (assoc :--id a)) :auth-token auth-token :fields fields))
 474        answers)))))
 475
 476 (define-backend-function get-post-comments (post-id &key (revalidate t) force-revalidate)
 477   (backend-graphql
 478    (let ((fn (lambda ()
 479                (comments-list-to-graphql-json
 480                 (get-post-comments-list post-id "postCommentsTop")))))
 481      (lw2-graphql-query-timeout-cached fn "post-comments-json" post-id :revalidate revalidate :force-revalidate force-revalidate)))
 482   (backend-ea-forum
 483    ;; Work around bizarre parent comment bug in EA forum
 484    (declare (ignore revalidate force-revalidate))
 485    (let ((comments (call-next-method)))
 486      (dolist (c comments)
 487        (if-let (parent-id-cons (assoc :parent-comment-id c))
 488                (if (and (string= (cdr parent-id-cons) "rjgZaK8uzHG3jAu2p")
 489                         (not (string= post-id "h26Kx7uGfQfNewi7d")))
 490                    (setf (cdr parent-id-cons) nil))))
 491      comments)))
 492
 493 (defun get-post-answers (post-id &key (revalidate t) force-revalidate)
 494   (let ((fn (lambda ()
 495               (let ((answers (get-post-comments-list post-id "questionAnswers")))
 496                 (comments-list-to-graphql-json
 497                  (append answers
 498                          (loop
 499                             for a in answers
 500                             nconc (get-post-comments-list post-id "repliesToAnswer" :parent-answer-id (cdr (assoc :--id a))))))))))
 501     (lw2-graphql-query-timeout-cached fn "post-answers-json" post-id :revalidate revalidate :force-revalidate force-revalidate)))
 502
 503 (define-backend-function get-notifications (&key user-id offset auth-token)
 504   (backend-lw2-legacy
 505    (lw2-graphql-query (lw2-query-string :notification :list
 506                                         (nconc (alist :user-id user-id :limit 21 :offset offset) *notifications-base-terms*)
 507                                         '(:--id :document-type :document-id :link :title :message :type :viewed))
 508                       :auth-token auth-token))
 509   (backend-lw2-modernized
 510    (declare (ignore user-id offset auth-token))
 511    (let ((*notifications-base-terms* (remove :null *notifications-base-terms* :key #'cdr)))
 512      (call-next-method))))
 513
 514 (define-backend-function check-notifications (user-id auth-token)
 515   (backend-lw2-legacy
 516    (multiple-value-bind (notifications user-info)
 517        (sb-sys:with-deadline (:seconds 5)
 518          (lw2-graphql-query-multi (list
 519                                    (lw2-query-string* :notification :list (nconc (alist :user-id user-id :limit 1) *notifications-base-terms*)
 520                                                       '(:created-at))
 521                                    (lw2-query-string* :user :single (alist :document-id user-id) '(:last-notifications-check)))
 522                                   :auth-token auth-token))
 523      (when (and notifications user-info)
 524        (local-time:timestamp> (local-time:parse-timestring (cdr (assoc :created-at (first notifications)))) (local-time:parse-timestring (cdr (assoc :last-notifications-check user-info)))))))
 525   (backend-lw2-modernized
 526    (declare (ignore user-id auth-token))
 527    (let ((*notifications-base-terms* (remove :null *notifications-base-terms* :key #'cdr)))
 528      (call-next-method))))
 529
 530 (define-backend-function get-user-posts (user-id &key offset limit (sort-type :date) drafts auth-token)
 531   (backend-lw2-legacy
 532    (declare (special *graphql-correct*))
 533    (let* ((posts-base-terms
 534            (cond
 535              (drafts (alist :view "drafts"))
 536              ((eq sort-type :score) (alist :view "best"))
 537              (t (alist :view "userPosts"))))
 538           (posts-base-terms
 539            (if (or drafts (boundp '*graphql-correct*))
 540                posts-base-terms
 541                (cons '(:meta . :null) posts-base-terms))))
 542      (lw2-graphql-query (lw2-query-string :post :list
 543                                           (nconc (remove nil (alist :offset offset :limit limit :user-id user-id) :key #'cdr) posts-base-terms)
 544                                           (posts-index-fields))
 545                         :auth-token auth-token))))
 546
 547 (define-backend-function get-conversation-messages (conversation-id auth-token)
 548   (backend-lw2-legacy
 549    (lw2-graphql-query-multi
 550     (list
 551      (lw2-query-string* :conversation :single (alist :document-id conversation-id) '(:title (:participants :display-name :slug)))
 552      (lw2-query-string* :message :list (alist :view "messagesConversation" :conversation-id conversation-id) *messages-index-fields*))
 553     :auth-token (hunchentoot:cookie-in "lw2-auth-token")))
 554   (backend-lw2-modernized
 555    (declare (ignore conversation-id auth-token))
 556    (let ((*messages-index-fields* (cons :html-body *messages-index-fields*)))
 557      (call-next-method))))
 558
 559 (defun lw2-search-query (query)
 560   (multiple-value-bind (req-stream req-status req-headers req-uri req-reuse-stream want-close)
 561     (drakma:http-request (algolia-search-uri *current-backend*)
 562                          :method :post :additional-headers '(("Origin" . "https://www.greaterwrong.com") ("Referer" . "https://www.greaterwrong.com/"))
 563                          :content (json:encode-json-alist-to-string `(("requests" . ,(loop for index in '("test_posts" "test_comments")
 564                                                                                            collect `(("indexName" . ,index)
 565                                                                                                      ("params" . ,(format nil "query=~A&hitsPerPage=20&page=0"
 566                                                                                                                           (url-rewrite:url-encode query))))))))
 567                          :want-stream t :close t)
 568     (declare (ignore req-status req-headers req-uri req-reuse-stream))
 569     (setf (flexi-stream-external-format req-stream) :utf-8)
 570     (unwind-protect
 571       (values-list (loop for r in (cdr (assoc :results (json:decode-json req-stream)))
 572                          collect (cdr (assoc :hits r))))
 573       (if want-close (close req-stream)))))
 574
 575 (defun make-rate-limiter (delay)
 576   (let ((rl-hash (make-hash-table :test 'equal :synchronized t)))
 577     (lambda (datum fn)
 578       (let ((unix-time (get-unix-time)))
 579         (if (sb-ext:with-locked-hash-table (rl-hash)
 580               (maphash (lambda (k v)
 581                          (if (> (- unix-time v) delay)
 582                              (remhash k rl-hash)))
 583                        rl-hash)
 584               (not (gethash datum rl-hash)))
 585             (progn
 586               (setf (gethash datum rl-hash) unix-time)
 587               (funcall fn))
 588             (error "Request aborted due to rate limit."))))))
 589
 590 (defmacro with-rate-limit (&body outer-body)
 591     `(let ((rate-limiter (make-rate-limiter 30)))
 592        (macrolet ((rate-limit ((key) &body inner-body)
 593                     `(funcall rate-limiter ,key (lambda () ,@inner-body))))
 594          ,@outer-body)))
 595
 596 (with-rate-limit
 597   (simple-cacheable ("post-title" "postid-to-title" post-id)
 598     (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) '(:title))))))))
 599
 600 (with-rate-limit
 601   (simple-cacheable ("post-slug" "postid-to-slug" post-id)
 602     (rate-limit (post-id) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :document-id post-id) '(:slug))))))))
 603
 604 (with-rate-limit
 605   (simple-cacheable ("slug-postid" "slug-to-postid" slug)
 606     (rate-limit (slug) (cdr (first (lw2-graphql-query (lw2-query-string :post :single (alist :slug slug) '(:--id))))))))
 607
 608 (with-rate-limit
 609   (simple-cacheable ("username" "userid-to-displayname" user-id)
 610     (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) '(:display-name))))))))
 611
 612 (with-rate-limit
 613   (simple-cacheable ("user-slug" "userid-to-slug" user-id)
 614     (rate-limit (user-id) (cdr (first (lw2-graphql-query (lw2-query-string :user :single (alist :document-id user-id) '(:slug))))))))
 615
 616 (defun preload-username-cache ()
 617   (let ((user-list (lw2-graphql-query (lw2-query-string :user :list '() '(:--id :display-name)))))
 618     (loop for user in user-list
 619           do (cache-username (cdr (assoc :--id user)) (cdr (assoc :display-name user))))))