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