lw2.lisp

   1 (uiop:define-package #:lw2-viewer
   2   (:use #:cl #:sb-thread #:flexi-streams #:djula #:iterate
   3         #:lw2-viewer.config #:lw2.utils #:lw2.lmdb #:lw2.backend #:lw2.links #:lw2.clean-html #:lw2.login #:lw2.context #:lw2.sites #:lw2.components #:lw2.html-reader #:lw2.fonts
   4         #:lw2.csrf
   5         #:lw2.graphql
   6         #:lw2.conditions
   7         #:lw2.routes
   8         #:lw2.response
   9         #:lw2.schema-type
  10         #:lw2.interface-utils
  11         #:lw2.user-context
  12         #:lw2.web-push
  13         #:lw2.data-viewers.post
  14         #:lw2.data-viewers.comment
  15         #:lw2.client-script
  16         #:lw2.resources)
  17   (:import-from #:alexandria #:with-gensyms #:once-only #:ensure-list #:when-let #:when-let* #:if-let #:alist-hash-table)
  18   (:import-from #:collectors #:with-collector)
  19   (:import-from #:ppcre #:regex-replace-all)
  20   (:unintern
  21     #:define-regex-handler #:*fonts-stylesheet-uri* #:generate-fonts-link
  22     #:user-nav-bar #:*primary-nav* #:*secondary-nav* #:*nav-bars*
  23     #:begin-html #:end-html
  24     #:*fonts-stylesheet-uris* #:*fonts-redirect-data* #:*fonts-redirect-lock* #:*fonts-redirect-thread*
  25     #:postprocess-conversation-title
  26     #:map-output
  27     #:*earliest-post*
  28     #:*extra-external-scripts* #:*extra-inline-scripts*
  29     #:site-stylesheets #:site-inline-scripts #:site-scripts #:site-external-scripts #:site-head-elements
  30     #:unwrap-stream
  31     #:sort-comments
  32     #:*html-head*
  33     #:with-open-tag)
  34   (:recycle #:lw2-viewer #:lw2.backend))
  35
  36 (in-package #:lw2-viewer)
  37
  38 (named-readtables:in-readtable html-reader)
  39
  40 (add-template-directory (asdf:system-relative-pathname "lw2-viewer" "templates/"))
  41
  42 (define-cache-database 'backend-lw2-legacy
  43     "auth-token-to-userid" "auth-token-to-username" "user-ignore-list")
  44
  45 (defvar *read-only-mode* nil)
  46 (defvar *read-only-default-message* "Due to a system outage, you cannot log in or post at this time.")
  47
  48 (defparameter *default-prefs* (alist :items-per-page 20 :default-sort "new"))
  49 (defvar *current-prefs* nil)
  50
  51 (defun get-post-sequences (post-id)
  52   (when-let (sequence-ids (get-post-sequence-ids post-id))
  53     (with-collector (col)
  54       (dolist (sequence-id sequence-ids)
  55         (let* ((sequence (get-sequence sequence-id))
  56                (posts (sequence-post-ids sequence)))
  57           (multiple-value-bind (prev next)
  58               (loop for prev = nil then (car current)
  59                  for current on posts
  60                  when (string= (car current) post-id)
  61                  return (values prev (second current)))
  62             (when (or prev next)
  63               (col (list sequence
  64                          (and prev (get-sequence-post sequence prev))
  65                          (and next (get-sequence-post sequence next))))))))
  66       (col))))
  67
  68 (defun rectify-post-relations (post-relations)
  69   (remove-if-not (lambda (pr) (cdr (assoc :--id (cdr (first pr))))) post-relations))
  70
  71 (defun post-nav-links (post post-sequences)
  72   <nav class="post-nav-links">
  73     (schema-bind (:post post (target-post-relations source-post-relations) :context :body)
  74       (let ((target-post-relations (rectify-post-relations target-post-relations))
  75             (source-post-relations (rectify-post-relations source-post-relations)))
  76         (when (or target-post-relations source-post-relations)
  77           <div class="related-posts">
  78           (dolist (relations `((,source-post-relations "Parent question")
  79                                (,target-post-relations "Sub-question")))
  80             (destructuring-bind (related-posts relation-type) relations
  81               (when related-posts
  82                 <div class="related-post-group">
  83                   <div class="related-post-type">("~A~A" relation-type (if (second related-posts) "s" ""))</div>
  84                   (dolist (post-relation related-posts)
  85                     (post-headline-to-html (or (cdr (assoc :source-post post-relation))
  86                                                (cdr (assoc :target-post post-relation)))))
  87                 </div>)))
  88           </div>)))
  89     (loop for (sequence prev next) in post-sequences do
  90       (progn
  91         <div class="post-nav-item sequence">
  92           <a class="post-nav sequence-title" href=("/s/~A" (cdr (assoc :--id sequence)))>
  93             <span class="post-nav-label">Part of the sequence:</span>
  94             <span class="post-nav-title">(safe (clean-text-to-html (cdr (assoc :title sequence))))</span>
  95           </a>
  96           (labels ((post-nav-link (direction post)
  97                      <a class=("post-nav ~A" (string-downcase direction)) href=(generate-item-link :post post)>
  98                        <span class="post-nav-label">(case direction (:prev "Previous: ") (:next "Next: "))</span>
  99                        <span class="post-nav-title">(safe (clean-text-to-html (cdr (assoc :title post))))</span>
 100                      </a>))
 101             (when prev (post-nav-link :prev prev))
 102             (when next (post-nav-link :next next)))
 103       </div>))
 104   </nav>)
 105
 106 (defun rectify-conversation (conversation)
 107   (alist-bind ((title (or null string)))
 108               conversation
 109     (if (or (null title) (string= title ""))
 110         (acons :title "[Untitled conversation]" conversation)
 111         conversation)))
 112
 113 (defun conversation-message-to-html (out-stream message)
 114   (alist-bind ((user-id string)
 115                (created-at string)
 116                (highlight-new boolean)
 117                (conversation list)
 118                (content list)
 119                (contents list)
 120                (html-body (or string null)))
 121               message
 122     (let ((conversation (rectify-conversation conversation)))
 123       (multiple-value-bind (pretty-time js-time) (pretty-time created-at)
 124         (format out-stream "<div class=\"comment private-message~A\"><div class=\"comment-meta\"><a class=\"author\" href=\"/users/~A\">~A</a> <span class=\"date\" data-js-date=\"~A\">~A~A</span><div class=\"comment-post-title\">Private message in: <a href=\"/conversation?id=~A\">~A</a></div></div><div class=\"body-text comment-body\">"
 125                 (if highlight-new " comment-item-highlight" "")
 126                 (encode-entities (get-user-slug user-id))
 127                 (encode-entities (get-username user-id))
 128                 js-time
 129                 pretty-time
 130                 (pretty-time-js)
 131                 (encode-entities (cdr (assoc :--id conversation)))
 132                 (encode-entities (cdr (assoc :title conversation)))))
 133       (labels ((ws (html-body) (let ((*memoized-output-stream* out-stream)) (clean-html* html-body))))
 134         (cond
 135           (contents (ws (cdr (assoc :html contents))))
 136           (html-body (ws html-body))
 137           (t (format out-stream "~{<p>~A</p>~}" (loop for block in (cdr (assoc :blocks content)) collect (encode-entities (cdr (assoc :text block))))))))
 138       (format out-stream "</div></div>"))))
 139
 140 (defun conversation-index-to-html (out-stream conversation)
 141   (alist-bind ((conversation-id string :--id)
 142                (title (or null string))
 143                (created-at (or null string))
 144                (participants list)
 145                (messages-total fixnum))
 146     (rectify-conversation conversation)
 147     (multiple-value-bind (pretty-time js-time) (if created-at (pretty-time created-at) (values "[Error]" 0))
 148       (format out-stream "<h1 class=\"listing\"><a href=\"/conversation?id=~A\">~A</a></h1><div class=\"post-meta\"><div class=\"conversation-participants\"><ul>~:{<li><a href=\"/users/~A\">~A</a></li>~}</ul></div><div class=\"messages-count\">~A</div><div class=\"date\" data-js-date=\"~A\">~A~A</div></div>"
 149               (encode-entities conversation-id)
 150               (encode-entities title)
 151               (loop for p in participants
 152                     collect (list (encode-entities (cdr (assoc :slug p))) (encode-entities (cdr (assoc :display-name p)))))
 153               (pretty-number messages-total "message")
 154               js-time
 155               pretty-time
 156               (pretty-time-js)))))
 157
 158 (defun collection-to-contents (collection &optional (heading-level 1) (used-anchors (make-hash-table :test 'equal)))
 159   (alist-bind ((title (or string null)))
 160               collection
 161               (let ((subcollections (cdr
 162                                      (find-if (lambda (x) (member (car x) '(:books :sequences :chapters) :test #'eq))
 163                                               collection)))
 164                     contents-head contents-tail)
 165                 (labels ((add-contents (c)
 166                            (when c
 167                              (if contents-head
 168                                  (setf (cdr contents-tail) c)
 169                                  (setf contents-head c))
 170                              (setf contents-tail (last c)))))
 171                   (cond
 172                     ((and title (not (cdr (assoc :books collection))))
 173                      (add-contents (list (list heading-level title (title-to-anchor title used-anchors))))
 174                      (dolist (subcollection subcollections)
 175                        (add-contents (collection-to-contents subcollection (1+ heading-level) used-anchors))))
 176                     (:otherwise
 177                      (dolist (subcollection subcollections)
 178                        (add-contents (collection-to-contents subcollection heading-level used-anchors)))))
 179                   contents-head))))
 180
 181 (defun collection-to-html (collection &optional (heading-level 1) (used-anchors (make-hash-table :test 'equal)))
 182   (alist-bind ((title (or string null))
 183                (subtitle (or string null))
 184                (number (or fixnum null))
 185                (contents list)
 186                (posts list))
 187               collection
 188               (let* ((subcollections (cdr
 189                                       (find-if (lambda (x) (member (car x) '(:books :sequences :chapters) :test #'eq))
 190                                                collection)))
 191                      (html-body (cdr (assoc :html contents))))
 192                 (cond
 193                   ((or html-body title posts)
 194                    <section>
 195                      (when (or html-body title)
 196                        <div class="body-text sequence-text">
 197                          (when title
 198                            (with-html-stream-output (:stream stream)
 199                              (format stream "<h~A id=\"~A\" class=\"sequence-chapter\">~@[~A. ~]~A</h~A>"
 200                                      heading-level
 201                                      (title-to-anchor title used-anchors)
 202                                      number
 203                                      (clean-text-to-html title)
 204                                      heading-level)))
 205                          (when (assoc :books collection)
 206                            (contents-to-html (collection-to-contents collection) 1 *html-output*))
 207                          (when subtitle
 208                            <div class="sequence-subtitle">(safe (clean-text-to-html subtitle))</div>)
 209                          (when html-body
 210                            (with-html-stream-output (:stream stream)
 211                              (let ((*memoized-output-stream* stream)) (clean-html* html-body))))
 212                          </div>)
 213                      (if posts
 214                          (dolist (post posts)
 215                            (post-headline-to-html post))
 216                          (dolist (subcollection subcollections)
 217                            (collection-to-html subcollection (1+ heading-level) used-anchors)))
 218                    </section>)
 219                   (:otherwise
 220                    (dolist (subcollection subcollections)
 221                      (collection-to-html subcollection heading-level used-anchors)))))))
 222
 223 (defun sequence-to-html (sequence)
 224   (labels ((contents-to-html (contents &key title subtitle number)
 225              (let ((html-body (cdr (assoc :html contents))))
 226                (when (or html-body title subtitle)
 227                  <div class="body-text sequence-text">
 228                    (when title
 229                      <h1 class="sequence-chapter">(safe (format nil "~@[~A. ~]~A" number (clean-text-to-html title :hyphenation nil)))</h1>)
 230                    (when subtitle
 231                      <div class="sequence-subtitle">(clean-text-to-html subtitle)</div>)
 232                    (with-html-stream-output (:stream stream)
 233                      (when html-body
 234                        (let ((*memoized-output-stream* stream)) (clean-html* html-body))))
 235                  </div>)))
 236            (chapter-to-html (chapter)
 237              (alist-bind ((title (or string null))
 238                            (subtitle (or string null))
 239                            (number (or fixnum null))
 240                            (contents list)
 241                            (posts list))
 242                          chapter
 243                 <section>
 244                   (with-html-stream-output
 245                     (contents-to-html contents :title title :subtitle subtitle :number number)
 246                     <section>
 247                       (with-html-stream-output
 248                           (dolist (post posts)
 249                             (post-headline-to-html post)))
 250                     </section>)
 251                 </section>)))
 252   (alist-bind ((sequence-id string :--id)
 253                (title string)
 254                (created-at string)
 255                (user-id string)
 256                (chapters list)
 257                (contents list))
 258               sequence
 259     (multiple-value-bind (pretty-time js-time) (pretty-time created-at)
 260       <article>
 261         (if chapters
 262           <h1 class="post-title">(safe (clean-text-to-html title :hyphenation nil))</h1>
 263           <h1 class="listing"><a href=("/s/~A" sequence-id)>(safe (clean-text-to-html title :hyphenation nil))</a></h1>)
 264         <div class="post-meta">
 265           <a class=("author~{ ~A~}" (list-cond ((logged-in-userid user-id) "own-user-author")))
 266              href=("/users/~A" (get-user-slug user-id))
 267              data-userid=user-id>
 268             (get-username user-id)
 269           </a>
 270           <div class="date" data-js-date=js-time>
 271             (safe pretty-time)
 272             (safe (pretty-time-js))
 273           </div>
 274         </div>
 275         (with-html-stream-output
 276             (when chapters
 277               (contents-to-html contents)
 278               (dolist (chapter chapters)
 279                 (chapter-to-html chapter))))
 280       </article>))))
 281
 282 (defun abort-response ()
 283   (throw 'abort-response nil))
 284
 285 (defun abort-response-if-unrecoverable (condition)
 286   (when (html-output-stream-error-p condition)
 287     (abort-response)))
 288
 289 (defmacro with-error-html-block (() &body body)
 290   "If an error occurs within BODY, write an HTML representation of the
 291 signaled condition to *HTML-OUTPUT*."
 292   `(block with-error-html-block
 293      (handler-bind ((serious-condition (lambda (c)
 294                                          (abort-response-if-unrecoverable c)
 295                                          (error-to-html c)
 296                                          (return-from with-error-html-block nil))))
 297        (log-conditions (progn ,@body)))))
 298
 299 (defun make-comment-parent-hash-real (comments)
 300   (let ((existing-comment-hash (make-hash-table :test 'equal))
 301         (hash (make-hash-table :test 'equal)))
 302     (dolist (c comments)
 303       (if-let (id (cdr (assoc :--id c)))
 304               (setf (gethash id existing-comment-hash) t)))
 305     (dolist (c comments)
 306       (let* ((parent-id (cdr (assoc :parent-comment-id c)))
 307              (old (gethash parent-id hash)))
 308         (setf (gethash parent-id hash) (cons c old))
 309         (when (and parent-id (not (gethash parent-id existing-comment-hash)))
 310           (let ((placeholder (alist :--id parent-id :parent-comment-id nil :deleted t)))
 311             (setf (gethash parent-id existing-comment-hash) t
 312                   (gethash nil hash) (cons placeholder (gethash nil hash)))))))
 313     (maphash (lambda (k old)
 314                (setf (gethash k hash) (nreverse old)))
 315              hash)
 316     (labels
 317       ((count-children (parent)
 318         (let ((children (gethash (cdr (assoc :--id parent)) hash)))
 319           (+ (length children) (apply #'+ (map 'list #'count-children children)))))
 320        (add-child-counts (comment-list)
 321         (loop for c in comment-list
 322               as id = (cdr (assoc :--id c))
 323               do (setf (gethash id hash) (add-child-counts (gethash id hash)))
 324               collecting (cons (cons :child-count (count-children c)) c))))
 325       (setf (gethash nil hash) (add-child-counts (gethash nil hash))))
 326     hash))
 327
 328 (defparameter *comment-parent-hash-cache* (make-hash-table :test 'eq
 329                                                            :weakness :value
 330                                                            :synchronized t))
 331
 332 (defun make-comment-parent-hash (comments)
 333   (or (gethash comments *comment-parent-hash-cache*)
 334       (setf (gethash comments *comment-parent-hash-cache*) (make-comment-parent-hash-real comments))))
 335
 336 (defun comment-thread-to-html (out-stream emit-comment-item-fn)
 337   (format out-stream "<ul class=\"comment-thread\">")
 338   (funcall emit-comment-item-fn)
 339   (format out-stream "</ul>"))
 340
 341 (defun comment-item-to-html (out-stream comment &key extra-html-fn with-post-title level level-invert)
 342   (with-error-html-block ()
 343     (let ((c-id (cdr (assoc :--id comment)))
 344           (user-id (cdr (assoc :user-id comment))))
 345       (format out-stream "<li id=\"comment-~A\" class=\"comment-item~{ ~A~}\">"
 346               c-id
 347               (list-cond
 348                (t (if (let ((is-odd (or (not level) (evenp level)))) ;inverted because level counts from 0
 349                         (if level-invert (not is-odd) is-odd))
 350                       "depth-odd" "depth-even"))
 351                ((and *current-ignore-hash* (gethash user-id *current-ignore-hash*)) "ignored")))
 352       (unwind-protect
 353         (comment-to-html out-stream comment :with-post-title with-post-title)
 354         (if extra-html-fn (funcall extra-html-fn c-id))
 355         (format out-stream "</li>")))))
 356
 357 (defun comment-tree-to-html (out-stream comment-hash &key (target nil) (level (if target 1 0)) level-invert)
 358   (let ((comments (gethash target comment-hash)))
 359     (when comments
 360       (comment-thread-to-html out-stream
 361         (lambda ()
 362           (loop for c in comments do
 363                (comment-item-to-html out-stream c
 364                  :level level
 365                  :level-invert level-invert
 366                  :extra-html-fn (lambda (c-id)
 367                                   (if (and (= level 10) (gethash c-id comment-hash))
 368                                       (format out-stream "<input type=\"checkbox\" id=\"expand-~A\"><label for=\"expand-~:*~A\" data-child-count=\"~A comment~:P\">Expand this thread</label>"
 369                                               c-id
 370                                               (cdr (assoc :child-count c))))
 371                                   (comment-tree-to-html out-stream comment-hash :target c-id :level (1+ level) :level-invert level-invert)))))))))
 372
 373 (defun sort-items (items sort-by)
 374   (multiple-value-bind (sort-fn key-fn)
 375       (ecase sort-by
 376         ((:old :new) (values (if (eq sort-by :old)
 377                                  (lambda (a b) (ignore-errors (local-time:timestamp< a b)))
 378                                  (lambda (a b) (ignore-errors (local-time:timestamp> a b))))
 379                              (lambda (c) (ignore-errors (local-time:parse-timestring (or (cdr (assoc :posted-at c))
 380                                                                                          (cdr (assoc :created-at c)))))))))
 381     (sort items sort-fn :key key-fn)))
 382
 383 (defun comment-chrono-to-html (out-stream comments)
 384   (let ((comment-hash (make-comment-parent-hash comments))
 385         (comments (sort-items comments :old)))
 386     (comment-thread-to-html out-stream
 387       (lambda ()
 388         (loop for c in comments do
 389               (let* ((c-id (cdr (assoc :--id c)))
 390                      (new-c (acons :children (gethash c-id comment-hash) c)))
 391                 (comment-item-to-html out-stream new-c)))))))
 392
 393 (defun comment-post-interleave (list &key limit offset (sort-by :date))
 394   (multiple-value-bind (sort-fn sort-key)
 395     (ecase sort-by
 396       (:date (values #'local-time:timestamp> (lambda (x) (local-time:parse-timestring (cdr (assoc :posted-at x))))))
 397       (:date-reverse (values #'local-time:timestamp< (lambda (x) (local-time:parse-timestring (cdr (assoc :posted-at x))))))
 398       (:score (values #'> (lambda (x) (cdr (assoc :base-score x))))))
 399     (let ((sorted (sort list sort-fn :key sort-key)))
 400       (loop for end = (if (or limit offset) (+ (or limit 0) (or offset 0)))
 401             for x in sorted
 402             for count from 0
 403             until (and end (>= count end))
 404             when (or (not offset) (>= count offset))
 405             collect x))))
 406
 407 (defun identify-item (x)
 408   (typecase x
 409     (cons
 410      (if-let (typename (cdr (assoc :----typename x)))
 411              (find-symbol (string-upcase typename) (find-package :keyword))
 412              (cond
 413                ((assoc :message x)
 414                 :notification)
 415                ((assoc :comment-count x)
 416                 :post)
 417                (t
 418                 :comment))))
 419     (condition :condition)))
 420
 421 (defun write-index-items-to-html (out-stream items &key need-auth (empty-message "No entries.") skip-section)
 422   (if items
 423       (dolist (x items)
 424         (with-error-html-block ()
 425           (ecase (identify-item x)
 426             (:condition
 427              (error-to-html x))
 428             (:notification
 429              (format out-stream "<p>~A</p>" (cdr (assoc :message x))))
 430             (:message
 431              (format out-stream "<ul class=\"comment-thread\"><li class=\"comment-item depth-odd\">")
 432              (unwind-protect
 433                   (conversation-message-to-html out-stream x)
 434                (format out-stream "</li></ul>")))
 435             (:conversation
 436              (conversation-index-to-html out-stream x))
 437             (:post
 438              (post-headline-to-html x :need-auth (or need-auth (cdr (assoc :draft x))) :skip-section skip-section))
 439             (:comment
 440              (comment-thread-to-html out-stream
 441                                      (lambda () (comment-item-to-html out-stream x :with-post-title t))))
 442             (:sequence
 443              (sequence-to-html x)))))
 444       (format out-stream "<div class=\"listing-message\">~A</div>" empty-message)))
 445
 446 (defun write-index-items-to-rss (out-stream items &key title need-auth)
 447   (let ((full-title (format nil "~@[~A - ~]~A" title (site-title *current-site*)))
 448         (items (firstn (sort-items items :new) 20)))
 449     (xml-emitter:with-rss2 (out-stream :encoding "UTF-8")
 450       (xml-emitter:rss-channel-header full-title (site-uri *current-site*) :description full-title)
 451       (labels ((emit-item (item &key title link (guid (cdr (assoc :--id item))) (author (get-username (cdr (assoc :user-id item))))
 452                                 (date (pretty-time (cdr (assoc :posted-at item)) :format local-time:+rfc-1123-format+)) body)
 453                           (xml-emitter:rss-item
 454                             title
 455                             :link link
 456                             :author author
 457                             :pubDate date
 458                             :guid guid
 459                             :description body)))
 460         (dolist (item items)
 461           (ecase (identify-item item)
 462             (:post
 463              (let ((author (get-username (cdr (assoc :user-id item))))
 464                    (is-event (cdr (assoc :is-event item))))
 465                (emit-item item
 466                           :title (clean-text (format nil "~A by ~A" (cdr (assoc :title item)) author))
 467                           :author author
 468                           :link (generate-post-auth-link item :absolute t :need-auth need-auth :item-subtype (if is-event "event" "post"))
 469                           :body (clean-html (or (cdr (assoc :html-body (get-post-body (cdr (assoc :--id item)) :revalidate nil))) "") :post-id (cdr (assoc :--id item))))))
 470             (:comment
 471              (schema-bind (:comment item (comment-id post-id user-id html-body))
 472                (when post-id ; XXX fixme
 473                  (emit-item item
 474                             :title (format nil "Comment by ~A on ~A" (get-username user-id) (get-post-title post-id))
 475                             :link (generate-item-link :post post-id :comment-id comment-id :absolute t)
 476                             :body (clean-html html-body)))))))))))
 477
 478 (defun search-bar-to-html (out-stream)
 479   (declare (special *current-search-query*))
 480   (let ((query (and (boundp '*current-search-query*) (hunchentoot:escape-for-html *current-search-query*))))
 481     (format out-stream "<form action=\"/search\" class=\"nav-inner\"><input name=\"q\" type=\"search\" ~@[value=\"~A\"~] autocomplete=\"off\" accesskey=\"s\" title=\"Search [s]~@[&#10;Tip: Paste a ~A URL here to jump to that page.~]\"><button>Search</button></form>" query (main-site-title *current-site*))))
 482
 483 (defun inbox-to-html (out-stream user-slug &optional new-messages)
 484   (let* ((target-uri (format nil "/users/~A?show=inbox" user-slug))
 485          (as-link (string= (hunchentoot:request-uri*) target-uri)))
 486     (multiple-value-bind (nm-class nm-text)
 487       (if new-messages (values "new-messages" "New messages") (values "no-messages" "Inbox"))
 488       (format out-stream "<~:[a href=\"~A\"~;span~*~] id=\"inbox-indicator\" class=\"~A\" accesskey=\"o\" title=\"~A~:[ [o]~;~]\">~A</a>"
 489               as-link target-uri nm-class nm-text as-link nm-text))))
 490
 491 (defmethod site-nav-bars ((site site))
 492   '((:secondary-bar (("archive" "/archive" "Archive" :accesskey "r")
 493                      ("about" "/about" "About" :accesskey "t")
 494                      ("search" "/search" "Search" :html search-bar-to-html)
 495                      user-nav-item))
 496     (:primary-bar (("home" "/" "Home" :description "Latest frontpage posts" :accesskey "h")
 497                    ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description "Latest comments" :accesskey "c")))))
 498
 499 (defmethod site-nav-bars ((site lesswrong-viewer-site))
 500   '((:secondary-bar (("archive" "/archive" "Archive" :accesskey "r")
 501                      ("sequences" "/library" "Sequences" :description "Sequences" :accesskey "q")
 502                      ("about" "/about" "About" :accesskey "t")
 503                      ("search" "/search" "Search" :html search-bar-to-html)
 504                      user-nav-item))
 505     (:tertiary-bar (("questions" "/index?view=questions" "Questions")
 506                     ("events" "/index?view=events" "Events")
 507                     ("shortform" "/shortform" "Shortform" :description "Latest Shortform posts")
 508                     ("alignment-forum" "/index?view=alignment-forum" "Alignment Forum")
 509                     ("alignment-forum-comments" "/recentcomments?view=alignment-forum" "AF Comments")))
 510     (:primary-bar (("home" "/" "Home" :description "Latest frontpage posts" :accesskey "h")
 511                    ("featured" "/index?view=featured" "Featured" :description "Latest featured posts" :accesskey "f")
 512                    ("all" "/index?view=all" "All" :description "Latest posts from all sections" :accesskey "a")
 513                    ("tags" "/tags" "Tags" :description "All tags" :accesskey "v")
 514                    ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description "Latest comments" :accesskey "c")))))
 515
 516 (defmethod site-nav-bars ((site ea-forum-viewer-site))
 517   '((:secondary-bar (("archive" "/archive" "Archive" :accesskey "r")
 518                      ("about" "/about" "About" :accesskey "t")
 519                      ("search" "/search" "Search" :html search-bar-to-html)
 520                      user-nav-item))
 521     (:primary-bar (("home" "/" "Home" :description "Latest frontpage posts" :accesskey "h")
 522                    ("all" "/index?view=all" "All" :description "Latest posts from all sections" :accesskey "a")
 523                    ("tags" "/tags" "Wiki" :description "Wiki pages and tags" :accesskey "v")
 524                    ("shortform" "/shortform" "Shortform" :description "Latest Shortform posts")
 525                    ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description "Latest comments" :accesskey "c")))))
 526
 527 (defmethod site-nav-bars ((site progress-forum-viewer-site))
 528   '((:secondary-bar (("archive" "/archive" "Archive" :accesskey "r")
 529                      ("about" "/about" "About" :accesskey "t")
 530                      ("search" "/search" "Search" :html search-bar-to-html)
 531                      user-nav-item))
 532     (:tertiary-bar (("questions" "/index?view=questions" "Questions")
 533                     ("events" "/index?view=events" "Events")
 534                     ("shortform" "/shortform" "Shortform" :description "Latest Shortform posts")))
 535     (:primary-bar (("home" "/" "Home" :description "Latest frontpage posts" :accesskey "h")
 536                    ("featured" "/index?view=featured" "Featured" :description "Latest featured posts" :accesskey "f")
 537                    ("all" "/index?view=all" "All" :description "Latest posts from all sections" :accesskey "a")
 538                    ("tags" "/tags" "Tags" :description "All tags" :accesskey "v")
 539                    ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description "Latest comments" :accesskey "c")))))
 540
 541 (defun prepare-nav-bar (nav-bar current-uri)
 542   (list (first nav-bar)
 543         (map 'list (lambda (item) (if (listp item) item (funcall item current-uri)))
 544              (second nav-bar))))
 545
 546 (defun nav-item-active (item current-uri)
 547   (when item
 548     (destructuring-bind (id uri name &key description html accesskey nofollow trailing-html override-uri) item
 549       (declare (ignore id name description html accesskey nofollow trailing-html))
 550       (string= (or override-uri uri) current-uri))))
 551
 552 (defun nav-bar-active (nav-bar current-uri)
 553   (some (lambda (x) (nav-item-active x current-uri)) (second nav-bar)))
 554
 555 (defun nav-bar-inner (out-stream items &optional current-uri)
 556   (maplist (lambda (items)
 557              (let ((item (first items)))
 558                (destructuring-bind (id uri name &key description html accesskey nofollow trailing-html override-uri) item
 559                  (declare (ignore override-uri))
 560                  (let* ((item-active (nav-item-active item current-uri))
 561                         (nav-class (format nil "nav-item ~:[nav-inactive~;nav-current~]~:[~; nav-item-last-before-current~]"
 562                                            item-active (and (not item-active) (nav-item-active (cadr items) current-uri)))))
 563                      (format out-stream "<span id=\"nav-item-~A\" class=\"~A\" ~@[title=\"~A\"~]>"
 564                              id nav-class description)
 565                      (if html
 566                          (funcall html out-stream)
 567                          (link-if-not out-stream item-active uri "nav-inner" name :accesskey accesskey :nofollow nofollow))
 568                      (if trailing-html
 569                          (funcall trailing-html out-stream))
 570                      (format out-stream "</span>")))))
 571            items))
 572
 573 (defun nav-bar-outer (out-stream class nav-bar &optional current-uri)
 574   (format out-stream "<nav id=\"~A\" class=\"nav-bar~@[ ~A~]\">" (string-downcase (first nav-bar)) class)
 575   (nav-bar-inner out-stream (second nav-bar) current-uri)
 576   (format out-stream "</nav>"))
 577
 578 (defun nav-bar-to-html (out-stream class current-uri)
 579   (let* ((nav-bars (map 'list (lambda (x) (prepare-nav-bar x current-uri)) (site-nav-bars *current-site*)))
 580          (active-bar (or (find-if (lambda (x) (nav-bar-active x current-uri)) nav-bars) (car (last nav-bars))))
 581          (inactive-bars (remove active-bar nav-bars)))
 582     (dolist (bar inactive-bars)
 583       (nav-bar-outer out-stream (format nil "~@[~A ~]inactive-bar" class) bar current-uri))
 584     (nav-bar-outer out-stream (format nil "~@[~A ~]active-bar" class) active-bar current-uri)))
 585
 586 (defun user-nav-item (&optional current-uri)
 587   (if *read-only-mode*
 588       `("login" "/login" "Read Only Mode" :html ,(lambda (out-stream)
 589                                                          (format out-stream "<span class=\"nav-inner\" title=\"~A\">[Read Only Mode]</span>"
 590                                                                  (typecase *read-only-mode*
 591                                                                    (string *read-only-mode*)
 592                                                                    (t *read-only-default-message*)))))
 593       (if-let (username (logged-in-username))
 594               (let ((user-slug (encode-entities (logged-in-user-slug))))
 595                 `("login" ,(format nil "/users/~A" user-slug) ,(plump:encode-entities username) :description "User page" :accesskey "u"
 596                           :trailing-html ,(lambda (out-stream) (inbox-to-html out-stream user-slug))))
 597               `("login" "/login" "Log In"
 598                         :html ,(lambda (out-stream)
 599                                  (write-string "<form action='/login' id='login-button-form'><input type='hidden' name='return' value='" out-stream)
 600                                  (encode-entities current-uri out-stream)
 601                                  (write-string "'></form><button class='nav-inner' form='login-button-form' accesskey='u'>Log In</button>" out-stream))))))
 602
 603 (defun sublevel-nav-to-html (options current &key default (base-uri (hunchentoot:request-uri*)) (param-name "show") (remove-params '("offset")) extra-class)
 604   (declare (type (or null string) extra-class))
 605   (let ((out-stream *html-output*))
 606     (format out-stream "<nav class=\"sublevel-nav~@[ ~A~]\">" extra-class)
 607     (loop for item in options
 608        do (destructuring-bind (param-value &key (text (string-capitalize param-value)) description) (if (atom item) (list item) item)
 609             (let* ((param-value (string-downcase param-value))
 610                    (selected (string-equal current param-value))
 611                    (class (if selected "sublevel-item selected" "sublevel-item")))
 612               (link-if-not out-stream selected (apply #'replace-query-params base-uri param-name (unless (string-equal param-value default) param-value)
 613                                                       (loop for x in remove-params nconc (list x nil)))
 614                            class text :title description))))
 615     (format out-stream "</nav>")))
 616
 617 (defmacro set-script-variables (&rest clauses)
 618   (with-gensyms (out-stream name value)
 619     `(with-html-stream-output (:stream ,out-stream)
 620        ,.(loop for clause in clauses
 621             collect (destructuring-bind (name-form value-form) clause
 622                       `(let ((,name ,name-form)
 623                              (,value ,value-form))
 624                          (declare (dynamic-extent ,name ,value))
 625                          (write-string ,name ,out-stream)
 626                          (write-string "=" ,out-stream)
 627                          (json:encode-json ,value ,out-stream)
 628                          (write-string #.(format nil ";~%") ,out-stream)))))))
 629
 630 (defun html-body (out-stream fn &key title description social-description current-uri content-class robots extra-head)
 631   (macrolet ((for-resource-type ((resource-type &rest args) &body body)
 632                (with-gensyms (resource)
 633                  `(dolist (,resource page-resources)
 634                     (when (eq (first ,resource) ,resource-type)
 635                       (destructuring-bind ,args (rest ,resource)
 636                         ,@body))))))
 637     (with-html-stream-output
 638         (let* ((session-token (hunchentoot:cookie-in "session-token"))
 639                (csrf-token (and session-token (make-csrf-token session-token)))
 640                (hide-nav-bars (truthy-string-p (hunchentoot:get-parameter "hide-nav-bars")))
 641                (preview *preview*)
 642                (page-resources (nreverse *page-resources*))
 643                (site-domain (site-domain *current-site*)))
 644           (setf *page-resources* nil)
 645           (write-string "<!DOCTYPE html><html lang=\"en-US\"><head>
 646 <meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">
 647 <meta name=\"HandheldFriendly\" content=\"True\" />"
 648                         out-stream)
 649           (with-delimited-writer (out-stream delimit :begin "<script>" :end "</script>")
 650             (when site-domain
 651               (delimit)
 652               (set-script-variables ("document.domain" site-domain))) ; Requires origin-agent-cluster header, see below
 653             (unless preview
 654               (delimit)
 655               (when (typep *current-site* 'login-site)
 656                 (set-script-variables
 657                  ("loggedInUserId" (or (logged-in-userid) ""))
 658                  ("loggedInUserDisplayName" (or (logged-in-username) ""))
 659                  ("loggedInUserSlug" (or (logged-in-user-slug) ""))))
 660               (set-script-variables
 661                ("applicationServerKey" (get-vapid-public-key))
 662                ("GW" (alist "useFancyFeatures" (not (typep *current-site* 'arbital-site))
 663                             "secureCookies" (to-boolean (site-secure *current-site*))
 664                             "csrfToken" csrf-token
 665                             "assets" (alist "popup.svg" (generate-versioned-link "/assets/popup.svg"))
 666                             "sites" (if site-domain
 667                                         (loop for site in *sites*
 668                                            when (let ((sd (site-domain site))) (and sd (string-equal sd site-domain)))
 669                                            collect (cons (site-host site) t))
 670                                         (alist (site-host *current-site*) t)))))
 671               (for-resource-type (:inline-script script-text)
 672                                  (write-string ";" out-stream)
 673                                  (write-string script-text out-stream))))
 674           (unless preview
 675             (funcall lw2.resources::*script-tags* out-stream)
 676             (for-resource-type (:script uri)
 677                                (format out-stream "<script src=\"~A\"></script>" uri))
 678             (funcall lw2.resources::*async-script-tags* out-stream)
 679             (for-resource-type (:async-script uri)
 680                                (format out-stream "<script src=\"~A\" async></script>" uri)))
 681           (funcall lw2.resources::*style-tags* out-stream)
 682           (for-resource-type (:stylesheet uri &key media class)
 683                              (format out-stream "<link rel=\"stylesheet\" href=\"~A\"~@[ media=\"~A\"~]~@[ class=\"~A\"~]>" uri media class))
 684           (generate-fonts-html-headers (site-fonts-source *current-site*))
 685           (format out-stream "<link rel=\"shortcut icon\" href=\"~A\">"
 686                   (generate-versioned-link "/assets/favicon.ico"))
 687           (format out-stream "<title>~@[~A - ~]~A</title>~@[<meta name=\"description\" content=\"~A\">~]~@[<meta name=\"robots\" content=\"~A\">~]"
 688                   (if title (encode-entities title))
 689                   (site-title *current-site*)
 690                   description
 691                   robots)
 692           (unless preview
 693             (when title
 694               <meta property="og:title" content=title>)
 695             (when social-description
 696               <meta property="og:description" content=social-description>
 697               <meta property="og:type" content="article">))
 698           (with-delimited-writer (out-stream delimit :begin "<style>" :between #.(format nil "~%") :end "</style>")
 699             (unless (and (typep *current-site* 'login-site) (logged-in-userid))
 700               (delimit)
 701               (write-string "button.vote { display: none }" out-stream))
 702             (when *memoized-output-without-hyphens*
 703               ;; The browser has been detected as having bugs related to soft-hyphen characters.
 704               ;; But there is some hope that it could still do hyphenation by itself.
 705               (delimit)
 706               (write-string ".body-text { hyphens: auto; -ms-hyphens: auto; -webkit-hyphens: auto; }" out-stream)))
 707           (when preview
 708             (format out-stream "<base target='_top'>"))
 709           (when extra-head (funcall extra-head))
 710           (format out-stream "</head>")
 711           (unwind-protect
 712                (progn
 713                  (format out-stream "<body class=\"~{~A~^ ~}\"><div id=\"content\"~@[ class=\"~{~A~^ ~}\"~]>"
 714                          (let* ((theme (nonempty-string (hunchentoot:cookie-in "theme")))
 715                                 (dark-mode (nonempty-string (hunchentoot:cookie-in "dark-mode"))))
 716                            (list-cond (t (format nil "theme-~A" (or theme "default")))
 717                                       (dark-mode (format nil "force-~A-mode" dark-mode))))
 718                          (list-cond (content-class content-class)
 719                                     (hide-nav-bars "no-nav-bars")
 720                                     (preview "preview")))
 721                  (unless (or hide-nav-bars preview)
 722                    (nav-bar-to-html out-stream "nav-bar-top" (or current-uri (replace-query-params (hunchentoot:request-uri*) "offset" nil "sort" nil)))
 723                    (when (and (typep *current-site* 'login-site) (logged-in-userid))
 724                      (call-with-server-data 'process-user-status "/current-user-status")))
 725                  (activate-client-trigger "navBarLoaded")
 726                  (funcall fn))
 727             (format out-stream "</div></body></html>"))))))
 728
 729 (defun replace-query-params (uri &rest params)
 730   (let* ((quri (quri:uri uri))
 731          (old-params (quri:uri-query-params quri))
 732          (new-params (loop with out = old-params
 733                            for (param value) on params by #'cddr
 734                            do (if value
 735                                   (if-let (old-cons (assoc param out :test #'equal))
 736                                           (setf (cdr old-cons) value)
 737                                           (setf out (nconc out (list (cons param value)))))
 738                                   (setf out (remove-if (lambda (x) (equal (car x) param)) out)))
 739                            finally (return out))))
 740     (if new-params
 741       (setf (quri:uri-query-params quri) new-params)
 742       (setf (quri:uri-query quri) nil))
 743     (quri:render-uri quri)))
 744
 745 (defun pagination-nav-bars (&key offset total with-next (items-per-page (user-pref :items-per-page)))
 746   (if *preview*
 747       (lambda (out-stream fn)
 748         (declare (ignore out-stream))
 749         (funcall fn))
 750       (lambda (out-stream fn)
 751         (labels ((pages-to-end (n) (< (+ offset (* items-per-page n)) total)))
 752           (let* ((with-next (if total (pages-to-end 1) with-next))
 753                  (next (if (and offset with-next) (+ offset items-per-page)))
 754                  (prev (if (and offset (>= offset items-per-page)) (- offset items-per-page)))
 755                  (request-uri (hunchentoot:request-uri*))
 756                  (first-uri (if (and prev (> prev 0)) (replace-query-params request-uri "offset" nil)))
 757                  (prev-uri (if prev (replace-query-params request-uri "offset" (if (= prev 0) nil prev))))
 758                  (next-uri (if next (replace-query-params request-uri "offset" next)))
 759                  (last-uri (if (and total offset (pages-to-end 2))
 760                                (replace-query-params request-uri "offset" (- total (mod (- total 1) items-per-page) 1)))))
 761             (if (or next prev last-uri)
 762                 (labels ((write-item (uri class title accesskey)
 763                            (format out-stream "<a href=\"~A\" class=\"button nav-item-~A~:[ disabled~;~]\" title=\"~A [~A]\" accesskey=\"~A\"></a>"
 764                                    (or uri "#") class uri title accesskey accesskey)))
 765                   (format out-stream "<nav id='top-nav-bar'>")
 766                   (write-item first-uri "first" "First page" "\\")
 767                   (write-item prev-uri "prev" "Previous page" "[")
 768                   (format out-stream "<span class='page-number'><span class='page-number-label'>Page</span> ~A</span>" (+ 1 (/ (or offset 0) items-per-page)))
 769                   (write-item next-uri "next" "Next page" "]")
 770                   (write-item last-uri "last" "Last page" "/")
 771                   (format out-stream "</nav>")))
 772             (funcall fn)
 773             (nav-bar-outer out-stream nil (list :bottom-bar
 774                                                 (list-cond
 775                                                  (first-uri `("first" ,first-uri "Back to first"))
 776                                                  (prev-uri `("prev" ,prev-uri "Previous" :nofollow t))
 777                                                  (t `("top" "#top" "Back to top"))
 778                                                  (next-uri `("next" ,next-uri "Next" :nofollow t))
 779                                                  (last-uri `("last" ,last-uri "Last" :nofollow t)))))
 780             (format out-stream "<script>document.querySelectorAll('#bottom-bar').forEach(bb => { bb.classList.add('decorative'); });</script>"))))))
 781
 782 (defun decode-json-as-hash-table (json-source)
 783   (let (current-hash-table current-key)
 784     (declare (special current-hash-table current-key))
 785     (json:bind-custom-vars
 786      (:beginning-of-object (lambda () (setf current-hash-table (make-hash-table :test 'equal)))
 787       :object-key (lambda (x) (setf current-key x))
 788       :object-value (lambda (x) (setf (gethash current-key current-hash-table) x))
 789       :end-of-object (lambda () current-hash-table)
 790       :aggregate-scope '(current-hash-table current-key))
 791      (json:decode-json-from-source json-source))))
 792
 793 (defun get-ignore-hash (&optional (user-id (logged-in-userid)))
 794   (if-let (ignore-json (and user-id (cache-get "user-ignore-list" user-id)))
 795           (decode-json-as-hash-table ignore-json)
 796           (make-hash-table :test 'equal)))
 797
 798 (defmacro with-outputs ((out-stream) &body body)
 799   (with-gensyms (stream-sym)
 800     (let ((out-body (map 'list (lambda (x) `(princ ,x ,stream-sym)) body)))
 801       `(let ((,stream-sym ,out-stream))
 802          ,.out-body))))
 803
 804 (defun call-with-emit-page (out-stream fn &key title description social-description current-uri content-class (return-code 200) robots (pagination (pagination-nav-bars)) top-nav extra-head)
 805   (declare (ignore return-code))
 806   (ignore-errors
 807     (log-conditions
 808       (html-body out-stream
 809                  (lambda ()
 810                    (when top-nav (funcall top-nav))
 811                    (funcall pagination out-stream fn))
 812                  :title title :description description :social-description social-description :current-uri current-uri :content-class content-class :robots robots :extra-head extra-head))))
 813
 814 (defun set-cookie (key value &key (max-age (- (expt 2 31) 1)) (path "/"))
 815   (hunchentoot:set-cookie key :value value :path path :max-age max-age :secure (site-secure *current-site*)))
 816
 817 (defun set-default-headers (return-code)
 818   (setf (hunchentoot:content-type*) "text/html; charset=utf-8"
 819         (hunchentoot:return-code*) return-code
 820         (hunchentoot:header-out :link) (let ((output
 821                                               (with-output-to-string (stream)
 822                                                 (with-delimited-writer (stream delimit :between ",")
 823                                                   (funcall lw2.resources::*link-header* stream delimit)))))
 824                                          (when (> (length output) 0)
 825                                            output)))
 826   (unless lw2.resources::*push-option* (set-cookie "push" "t" :max-age (* 4 60 60))))
 827
 828 (defun user-pref (key)
 829   (or (cdr (assoc key *current-prefs*))
 830       (cdr (assoc key *default-prefs*))))
 831
 832 (defun set-user-pref (key value)
 833   (assert (boundp 'hunchentoot:*reply*))
 834   (if value
 835       (setf *current-prefs* (remove-duplicates (acons key value *current-prefs*) :key #'car :from-end t))
 836       (setf *current-prefs* (remove key *current-prefs* :key #'car)))
 837   (set-cookie "prefs" (quri:url-encode (json:encode-json-to-string *current-prefs*))))
 838
 839 (defmacro emit-page ((out-stream &rest args &key (return-code 200) &allow-other-keys) &body body)
 840   (once-only (return-code)
 841     `(progn
 842        (set-default-headers ,return-code)
 843        (with-response-stream (,out-stream)
 844          (dynamic-flet ((fn () ,@body))
 845            (call-with-emit-page ,out-stream
 846                                 #'fn
 847                                 ,@args))))))
 848
 849 (defmethod call-with-backend-context ((backend backend-token-login) (request (eql t)) fn)
 850   (let ((*current-auth-status* (safe-decode-json (hunchentoot:cookie-in "lw2-status"))))
 851     (multiple-value-bind (*current-auth-token* *current-userid* *current-username*)
 852         (let* ((auth-token (hunchentoot:cookie-in "lw2-auth-token"))
 853                (expires (cdr (assoc :expires *current-auth-status*))))
 854           (when (and (nonempty-string auth-token)
 855                      (not *read-only-mode*)
 856                      (or (null expires)
 857                          (and (integerp expires) (<= (get-unix-time) (- expires (* 60 60 24))))))
 858             (with-cache-readonly-transaction
 859                 (values
 860                  auth-token
 861                  (cache-get "auth-token-to-userid" auth-token)
 862                  (cache-get "auth-token-to-username" auth-token)))))
 863       (let ((*current-user-slug* (and *current-userid* (get-user-slug *current-userid*)))
 864             (*enable-rate-limit* (if *current-userid* nil *enable-rate-limit*)))
 865         (funcall fn)))))
 866
 867 (defmethod call-with-site-context ((site ignore-list-site) (request (eql t)) fn)
 868   (call-next-method
 869    site request
 870    (lambda ()
 871      (let ((*current-ignore-hash* (get-ignore-hash)))
 872        (funcall fn)))))
 873
 874 (defun call-with-error-page (fn)
 875   (with-response-context ()
 876     (let* ((*current-prefs* (safe-decode-json (hunchentoot:cookie-in "prefs")))
 877            (*preview* (string-equal (hunchentoot:get-parameter "format") "preview")))
 878       (multiple-value-bind (*revalidate-default* *force-revalidate-default*)
 879           (cond ((ppcre:scan "(?:^|,?)\\s*(?:no-cache|max-age=0)(?:$|,)" (hunchentoot:header-in* :cache-control))
 880                  (values t t))
 881                 (*preview*
 882                  (values nil nil))
 883                 (t
 884                  (values t nil)))
 885         (when (not *revalidate-default*)
 886           (setf (hunchentoot:header-out :cache-control) (format nil "public, max-age=~A" (* 5 60))
 887                 (hunchentoot:header-out :vary) "cookie"))
 888         (when (site-domain *current-site*)
 889           (setf (hunchentoot:header-out :origin-agent-cluster) "?0")) ; Allow document.domain in Chrome: https://developer.chrome.com/blog/immutable-document-domain/
 890         (let ((*memoized-output-without-hyphens*
 891                ;; Soft hyphen characters mess up middle-click paste and screen readers, so try to identify whether they are necessary.
 892                ;; See https://caniuse.com/?search=hyphens
 893                (if-let ((ua (hunchentoot:header-in* :user-agent)))
 894                        (regex-case ua
 895                                    (" Chrome/(\\d+)"
 896                                     (declare (regex-groups-min 1))
 897                                     (or (> (parse-integer (reg 0)) 87)
 898                                         (ppcre:scan "Macintosh|Android" ua)))
 899                                    (" Edge/(\\d+)"
 900                                     (declare (regex-groups-min 1))
 901                                     (> 19 (parse-integer (reg 0))))
 902                                    (t t))
 903                        t)))
 904           (with-page-resources
 905               (catch 'abort-response
 906                 (handler-bind
 907                     ((fatal-error (lambda (condition)
 908                                     (abort-response-if-unrecoverable condition)
 909                                     (let ((error-html (with-output-to-string (*html-output*) (error-to-html condition))))
 910                                       (emit-page (out-stream :title "Error" :return-code (condition-http-return-code condition) :content-class "error-page")
 911                                                  (write-string error-html out-stream)
 912                                                  (when (eq (hunchentoot:request-method*) :post)
 913                                                    <form method="post" class="error-retry-form">
 914                                                    (loop for (key . value) in (hunchentoot:post-parameters*)
 915                                                       do <input type="hidden" name=key value=value>)
 916                                                    <input type="submit" value="Retry">
 917                                                    </form>))
 918                                       (return-from call-with-error-page)))))
 919                   (log-conditions
 920                    (if (or (eq (hunchentoot:request-method*) :post)
 921                            (not (and (boundp '*test-acceptor*) (boundp '*hunchentoot-taskmaster*)))) ; TODO fix this hack
 922                        (funcall fn)
 923                        (sb-sys:with-deadline (:seconds (expt 1.3
 924                                                              (min (round (log 30 1.3))
 925                                                                   (- (hunchentoot:taskmaster-max-thread-count (symbol-value '*hunchentoot-taskmaster*))
 926                                                                      (hunchentoot:acceptor-requests-in-progress (symbol-value '*test-acceptor*))))))
 927                          (funcall fn))))))))))))
 928
 929 (defmacro with-error-page (&body body)
 930   `(dynamic-flet ((fn () ,@body)) (call-with-error-page #'fn)))
 931
 932 (defun output-form (out-stream method action id heading csrf-token fields button-label &key textarea end-html)
 933   (format out-stream "<form method=\"~A\" action=\"~A\" id=\"~A\"><h1>~A</h1>" method action id heading)
 934   (loop for (id label type . params) in fields
 935         do (format out-stream "<label for=\"~A\">~A:</label>" id label)
 936         do (cond
 937              ((string= type "select")
 938               (destructuring-bind (option-list &optional default) params
 939                 (format out-stream "<select name=\"~A\">" id)
 940                 (loop for (value label) in option-list
 941                       do (format out-stream "<option value=\"~A\"~:[~; selected~]>~A</option>" value (string= default value) label))
 942                 (format out-stream "</select>")))
 943              (t
 944                (destructuring-bind (&optional (autocomplete "off") default) params
 945                  (format out-stream "<input type=\"~A\" name=\"~A\" autocomplete=\"~A\"~@[ value=\"~A\"~]>" type id autocomplete (and default (encode-entities default))))))
 946         do (format out-stream ""))
 947   (if textarea
 948     (destructuring-bind (ta-name ta-contents) textarea
 949       (format out-stream "<div class=\"textarea-container\"><textarea name=\"~A\">~A</textarea><span class='markdown-reference-link'>You can use <a href='http://commonmark.org/help/' target='_blank'>Markdown</a> here.</span></div>" ta-name (encode-entities ta-contents))))
 950   (format out-stream "<input type=\"hidden\" name=\"csrf-token\" value=\"~A\"><input type=\"submit\" value=\"~A\">~@[~A~]</form>"
 951           csrf-token button-label end-html))
 952
 953 (defun page-toolbar-to-html (&key title new-post new-conversation logout (rss t) ignore enable-push-notifications)
 954   (unless *preview*
 955     (let ((out-stream *html-output*)
 956           (liu (logged-in-userid)))
 957       (format out-stream "<div class=\"page-toolbar~@[ hide-until-init~]\">" enable-push-notifications)
 958       (when logout
 959         (format out-stream "<form method=\"post\" action=\"/logout\"><input type=\"hidden\" name=\"csrf-token\" value=\"~A\"><button class=\"logout-button button\" name=\"logout\">Log out</button></form>"
 960                 (make-csrf-token)))
 961       (when ignore
 962         (funcall ignore))
 963       (when enable-push-notifications
 964         (format out-stream "<script>document.currentScript.outerHTML='<button id=\"enable-push-notifications\" class=\"button\" style=\"display: none\" data-enabled=\"~:[~;true~]\">~:*~:[En~;Dis~]able push notifications</button>'</script>"
 965                 (find-subscription *current-auth-token*)))
 966       (when (and new-conversation liu)
 967         (multiple-value-bind (text to)
 968             (typecase new-conversation (string (values "Send private message" new-conversation)) (t "New conversation"))
 969           (format out-stream "<a class=\"new-private-message button\" href=\"/conversation~@[?to=~A~]\">~A</a>"
 970                   to text)))
 971       (when (and new-post liu)
 972         (format out-stream "<a class=\"new-post button\" href=\"/edit-post~@[?section=~A~]\" accesskey=\"n\" title=\"Create new post [n]\">New post</a>"
 973                 (typecase new-post (string new-post) (t nil))))
 974       (when (and title rss)
 975         (format out-stream "<a class=\"rss\" rel=\"alternate\" type=\"application/rss+xml\" title=\"~A RSS feed\" href=\"~A\">RSS</a>"
 976                 title (replace-query-params (hunchentoot:request-uri*) "offset" nil "format" "rss")))
 977       (format out-stream "</div>"))))
 978
 979 (defun view-items-index (items &key section title current-uri hide-title need-auth extra-head (pagination (pagination-nav-bars)) (top-nav (lambda () (page-toolbar-to-html :title title))) (content-class "index-page") alternate-html)
 980   (alexandria:switch ((hunchentoot:get-parameter "format") :test #'string=)
 981                      ("rss"
 982                       (setf (hunchentoot:content-type*) "application/rss+xml; charset=utf-8")
 983                       (with-response-stream (out-stream)
 984                         (write-index-items-to-rss out-stream items :title title)))
 985                      (t
 986                        (emit-page (out-stream :title (if hide-title nil title) :description (site-description *current-site*) :content-class content-class
 987                                               :current-uri current-uri :robots (if (hunchentoot:get-parameter :offset) "noindex, nofollow")
 988                                               :pagination pagination :top-nav top-nav :extra-head extra-head)
 989                                   (if alternate-html
 990                                       (funcall alternate-html)
 991                                       (write-index-items-to-html out-stream items
 992                                                                  :need-auth need-auth
 993                                                                  :skip-section section))))))
 994
 995 (defun link-if-not (stream linkp url class text &key accesskey nofollow title)
 996   (declare (dynamic-extent linkp url text))
 997   (if (not linkp)
 998       (format stream "<a href=\"~A\" class=\"~A\"~@[ accesskey=\"~A\"~]~:[~; rel=\"nofollow\"~]~@[ title=\"~A\"~]>~A</a>" url class accesskey nofollow title text)
 999       (format stream "<span class=\"~A\"~@[ title=\"~A\"~]>~A</span>" class title text)))
1000
1001 (defgeneric main-site-link (site item-type item-designator &key)
1002   (:method ((site lw2-frontend-site) (item-type (eql :post)) (post-id string) &key slug comment-id direct-comment-link)
1003     (merge-uris
1004      (format nil "/posts/~A/~A~[~;#~A~;?commentId=~A~]" post-id slug (if comment-id (if direct-comment-link 2 1) 0) comment-id)
1005      (main-site-uri *current-site*)))
1006   (:method ((site lw2-frontend-site) (item-type (eql :tag)) (slug string) &key comment-id direct-comment-link)
1007     (when (not (and comment-id direct-comment-link))
1008       (merge-uris
1009        (format nil "/tag/~A~@[/discussion#~A~]" slug comment-id)
1010        (main-site-uri *current-site*)))))
1011
1012 (defun postprocess-markdown (markdown)
1013   (if (typep *current-site* 'alternate-frontend-site)
1014       (regex-replace-body
1015        ((concatenate 'string (regex-replace-all "\\." (site-uri *current-site*) "\\.") "posts/([^/ ]{17})/([^/# ]*)(?:(#comment-|/comment/|/answer/)([^/ ]{17}))?")
1016         markdown)
1017        (main-site-link *current-site*
1018                        :post (reg 0) :slug (reg 1) :comment-id (reg 3)
1019                        :direct-comment-link (and (reg 3) (reg 2) (string= "/" (reg 2) :end2 1))))
1020       markdown))
1021
1022 (defun redirect (uri &key (type :see-other) preserve-query)
1023   (setf (hunchentoot:return-code*) (ecase type (:see-other 303) (:permanent 301))
1024         (hunchentoot:header-out "Location") (if-let ((query (and preserve-query (hunchentoot:query-string*))))
1025                                                     (quri:render-uri (quri:make-uri :defaults uri :query query))
1026                                                     uri)))
1027
1028 (defun main-site-redirect (uri &key (type :see-other))
1029   (redirect (merge-uris uri (main-site-uri *current-site*)) :type type))
1030
1031 (defmacro request-method (&body method-clauses)
1032   (with-gensyms (request-method)
1033     `(let ((,request-method (hunchentoot:request-method*)))
1034        (cond
1035          ,.(loop for method-body in method-clauses
1036               collect (destructuring-bind (method args &body inner-body) method-body
1037                         `(,(if (eq method :get) `(member ,request-method '(:get :head)) `(eq ,request-method ,method))
1038                            ,(make-binding-form (mapcar (lambda (x) (append (ensure-list x) `(:request-type ,method))) args)
1039                                                inner-body))))))))
1040
1041 (defmacro define-page (name path-specifier additional-vars &body body)
1042   (labels ((make-lambda (args)
1043              (loop for a in args
1044                    collect (if (atom a) a (first a)))))
1045    (multiple-value-bind (path-specifier-form path-bindings-wrapper specifier-vars)
1046     (if (stringp path-specifier)
1047         (values path-specifier #'identity)
1048         (destructuring-bind (specifier-type specifier-body &rest specifier-args) path-specifier
1049           (ecase specifier-type
1050             (:function
1051               (values `(lambda (r) (funcall ,specifier-body (hunchentoot:request-uri r)))
1052                       (if specifier-args
1053                           (lambda (body) `(ignorable-multiple-value-bind ,(make-lambda specifier-args) (funcall ,specifier-body (hunchentoot:request-uri*)) ,body))
1054                           #'identity)
1055                       specifier-args))
1056             (:regex
1057               (let ((fn `(lambda (r) (ppcre:scan-to-strings ,specifier-body (hunchentoot:request-uri r)))))
1058                 (values fn
1059                         (lambda (body)
1060                           (with-gensyms (result-vector)
1061                             `(let ((,result-vector (nth-value 1 (funcall ,fn hunchentoot:*request*))))
1062                                (declare (type simple-vector ,result-vector)
1063                                         (ignorable ,result-vector))
1064                                (let
1065                                  ,(loop for v in (make-lambda specifier-args) as x from 0 collecting `(,v (if (> (length ,result-vector) ,x) (aref ,result-vector ,x))))
1066                                  ,body))))
1067                         specifier-args))))))
1068      `(hunchentoot:define-easy-handler (,name :uri ,path-specifier-form) ()
1069         (with-error-page
1070             (block nil
1071               ,(funcall path-bindings-wrapper
1072                         (make-binding-form (append (mapcar (lambda (x) (append (ensure-list x) '(:passthrough t))) specifier-vars) additional-vars)
1073                                            body))))))))
1074
1075 (define-component sort-widget (&key (sort-options '((:new :description "Sort by date posted")
1076                                                     (:hot :description "Sort by time-weighted score")
1077                                                     (:active :description "Sort by date posted or last comment")
1078                                                     (:old :description "Sort by date posted, oldest first")))
1079                                     (pref :default-sort) (param-name "sort") (html-class "sort"))
1080   (:http-args ((sort :real-name param-name :member (mapcar (lambda (x) (if (listp x) (first x) x)) sort-options))
1081                (sortedby :real-name "sortedBy" :type string)
1082                &without-csrf-check))
1083   (if sortedby
1084       (progn
1085         (renderer () nil)
1086         sortedby)
1087       (let ((sort-string (if sort (string-downcase sort))))
1088         (if sort-string
1089             (set-user-pref :default-sort sort-string))
1090         (renderer ()
1091                   (sublevel-nav-to-html sort-options
1092                                         (user-pref pref)
1093                                         :param-name param-name
1094                                         :extra-class html-class))
1095         (or sort-string (user-pref pref)))))
1096
1097 (defun handle-last-modified (last-modified)
1098   (when last-modified
1099     (let ((last-modified (max last-modified (load-time-value (get-universal-time)))))
1100       (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date last-modified)
1101             (hunchentoot:header-out :vary) "cookie")
1102       (hunchentoot:handle-if-modified-since last-modified))))
1103
1104 (define-component view-index ()
1105   (:http-args ((view :member '(:all :new :frontpage :featured :alignment-forum :questions :nominations :reviews :events) :default :frontpage)
1106                before after
1107                (offset :type fixnum)
1108                (limit :type fixnum :default (user-pref :items-per-page))
1109                (karma-threshold :type fixnum)
1110                &without-csrf-check))
1111   (when (eq view :new) (redirect (replace-query-params (hunchentoot:request-uri*) "view" "all" "all" nil) :type :permanent) (return))
1112   (component-value-bind ((sort-string sort-widget))
1113     (multiple-value-bind (posts total last-modified)
1114         (get-posts-index :view (string-downcase view) :before before :after after :offset offset :limit (1+ limit) :sort sort-string :karma-threshold karma-threshold)
1115       (handle-last-modified last-modified)
1116       (let ((page-title (format nil "~@(~A posts~)" view)))
1117         (renderer ()
1118                   (view-items-index (firstn posts limit)
1119                                     :section view :title page-title :hide-title (eq view :frontpage)
1120                                     :pagination (pagination-nav-bars :offset (or offset 0) :total total :with-next (and (not total) (> (length posts) limit)))
1121                                     :content-class (format nil "index-page ~(~A~)-index-page" view)
1122                                     :top-nav (lambda ()
1123                                                (page-toolbar-to-html :title page-title
1124                                                                      :new-post (if (eq view :meta) "meta" t))
1125                                                (funcall sort-widget))))))))
1126
1127 (defmacro route-component (name lambda-list &rest args)
1128   `(lambda ,lambda-list
1129      (with-error-page
1130          (component-value-bind ((() (,name ,@args)))
1131                                (when ,name
1132                                  (funcall ,name))))))
1133
1134 (defmacro define-component-routes (site-class &rest clauses)
1135   `(progn
1136      ,@(iter
1137         (for clause in clauses)
1138         (destructuring-bind (name (route-class &rest route-args) route-bindings (component-name &rest component-args)) clause
1139           (collect `(define-route ',site-class ',route-class
1140                       :name ',name ,@route-args
1141                       :handler (route-component ,component-name ,route-bindings ,@component-args)))))))
1142
1143 (define-component-routes forum-site
1144   (view-root (standard-route :uri "/") () (view-index))
1145   (view-index (standard-route :uri "/index") () (view-index)))
1146
1147 (hunchentoot:define-easy-handler
1148     (view-site-routes
1149      :uri (lambda (req)
1150             (declare (ignore req))
1151             (with-site-context ((let ((host (or (hunchentoot:header-in* :x-forwarded-host) (hunchentoot:header-in* :host))))
1152                                   (or (find-site host)
1153                                       (error "Unknown site: ~A" host))))
1154               (call-route-handler *current-site* (hunchentoot:script-name*)))))
1155     nil)
1156
1157 (define-page view-post "/post" ((id :required t))
1158   (redirect (generate-item-link :post id) :type :permanent))
1159
1160 (define-page view-post-lw1-link (:function #'match-lw1-link) ()
1161   (redirect (convert-lw1-link (hunchentoot:script-name*)) :preserve-query t :type :permanent))
1162
1163 (define-page view-post-ea1-link (:function #'match-ea1-link) ()
1164   (redirect (convert-ea1-link (hunchentoot:script-name*)) :preserve-query t :type :permanent))
1165
1166 (define-page view-post-lw2-slug-link (:function #'match-lw2-slug-link) ()
1167   (redirect (convert-lw2-slug-link (hunchentoot:request-uri*)) :type :see-other))
1168
1169 (define-page view-post-lw2-sequence-link (:function #'match-lw2-sequence-link) ()
1170   (redirect (convert-lw2-sequence-link (hunchentoot:request-uri*)) :type :see-other))
1171
1172 (define-page view-feed "/feed" ()
1173   (redirect "/?format=rss" :type :permanent))
1174
1175 (define-page view-allposts "/allPosts" ()
1176   (redirect (format nil "/index~@[?~A~]" (hunchentoot:query-string*)) :type :see-other))
1177
1178 (define-page view-nominations "/nominations" ()
1179   (redirect "/index?view=nominations" :type :see-other))
1180
1181 (define-page view-reviews "/reviews" ()
1182   (redirect "/index?view=reviews" :type :see-other))
1183
1184 (define-page view-review-voting "/reviewVoting" ()
1185   (redirect "https://www.lesswrong.com/reviewVoting" :type :see-other))
1186
1187 (define-page view-coronavirus-link-database "/coronavirus-link-database" ()
1188   (redirect "https://www.lesswrong.com/coronavirus-link-database" :type :see-other))
1189
1190 (defun post-comment (&key need-auth ((:post-id post-id-real)) ((:tag-id tag-id-real)) shortform)
1191   (request-method
1192    (:post (text answer nomination nomination-review af post-id tag-id parent-answer-id parent-comment-id edit-comment-id retract-comment-id unretract-comment-id delete-comment-id)
1193      (let ((lw2-auth-token *current-auth-token*))
1194        (assert lw2-auth-token)
1195        (let* ((post-id (or post-id-real post-id))
1196               (tag-id (or tag-id-real tag-id))
1197               (question (when post-id (cdr (assoc :question (get-post-body post-id :auth-token lw2-auth-token)))))
1198               (new-comment-result
1199                (cond
1200                  (text
1201                   (let ((comment-data
1202                          (list-cond
1203                           (t :body (postprocess-markdown text))
1204                           ((and post-id (not (or edit-comment-id (and shortform (not parent-comment-id))))) :post-id post-id)
1205                           ((and tag-id (not edit-comment-id)) :tag-id tag-id)
1206                           (parent-comment-id :parent-comment-id parent-comment-id)
1207                           (answer :answer t)
1208                           (nomination :nominated-for-review "2020")
1209                           (nomination-review :reviewing-for-review "2020")
1210                           (parent-answer-id :parent-answer-id parent-answer-id)
1211                           (af :af t)
1212                           ((and shortform (not parent-comment-id)) :shortform t))))
1213                     (if edit-comment-id
1214                         (do-lw2-comment-edit lw2-auth-token edit-comment-id comment-data)
1215                         (do-lw2-comment lw2-auth-token comment-data))))
1216                  (retract-comment-id
1217                   (do-lw2-comment-edit lw2-auth-token retract-comment-id '((:retracted . t))))
1218                  (unretract-comment-id
1219                   (do-lw2-comment-edit lw2-auth-token unretract-comment-id '((:retracted . :false))))
1220                  (delete-comment-id
1221                   (do-lw2-comment-remove lw2-auth-token delete-comment-id :reason "Comment deleted by its author.")
1222                   nil))))
1223          (when post-id
1224            (ignore-errors
1225              (get-post-comments post-id :force-revalidate t)
1226              (when question
1227                (get-post-answers post-id :force-revalidate t))))
1228          (when text
1229            (alist-bind ((new-comment-id simple-string :--id)
1230                         (new-comment-html simple-string :html-body))
1231                        new-comment-result
1232                        (mark-comment-replied (alist* :parent-comment-id parent-comment-id :user-id *current-userid* new-comment-result))
1233                        (setf (markdown-source :comment new-comment-id new-comment-html) text)
1234                        (redirect (merge-uris (quri:make-uri :fragment (format nil "comment-~A" new-comment-id)
1235                                                             :query (list-cond (need-auth "need-auth" "y")))
1236                                              (hunchentoot:request-uri*))))))))))
1237
1238 (defun output-comments (out-stream id comments target &key overcomingbias-sort preview chrono replies-open)
1239   (labels ((output-comments-inner ()
1240              (with-error-html-block ()
1241                (if target
1242                    (comment-thread-to-html out-stream
1243                                            (lambda ()
1244                                              (comment-item-to-html
1245                                               out-stream
1246                                               target
1247                                               :level-invert preview
1248                                               :extra-html-fn (lambda (c-id)
1249                                                                (let ((*comment-individual-link* nil))
1250                                                                  (comment-tree-to-html out-stream (make-comment-parent-hash comments)
1251                                                                                        :target c-id
1252                                                                                        :level-invert preview))))))
1253                    (if comments
1254                        (progn #|<div class="comments-empty-message">(safe (pretty-number (length comments) id))</div>|#
1255                          (if chrono
1256                              (comment-chrono-to-html out-stream comments)
1257                              (let ((parent-hash (make-comment-parent-hash comments)))
1258                                (when overcomingbias-sort
1259                                  (setf (gethash nil parent-hash)
1260                                        (sort-items (gethash nil parent-hash) :old)))
1261                                (comment-tree-to-html out-stream parent-hash))))
1262                        <div class="comments-empty-message">("No ~As." id)</div>)))))
1263     (if preview
1264         (output-comments-inner)
1265         (progn (format out-stream "<div id=\"~As\" class=\"comments~:[~; replies-open~]\">" id (and *enable-voting* replies-open))
1266                (unless target
1267                  <script>initializeCommentControls\(\)</script>)
1268                (output-comments-inner)
1269                (format out-stream "</div>")))))
1270
1271 (define-json-endpoint (view-karma-vote-post forum-site "/karma-vote/post")
1272   (let ((auth-token *current-auth-token*))
1273     (request-method
1274      (:get (post-id)
1275        (hash-cond (make-hash-table)
1276          (post-id "Post" (sethash (make-hash-table) post-id (get-post-vote post-id auth-token)))
1277          (post-id "Comment" (get-post-comments-votes post-id auth-token))
1278          (post-id "Tag" (get-post-tag-votes post-id auth-token)))))))
1279
1280 (define-page view-post-lw2-link (:function #'match-lw2-link post-id comment-id * comment-link-type post-type)
1281                                 (need-auth
1282                                  chrono
1283                                  (show-comments :real-name "comments" :type boolean :default t)
1284                                  (format :type string))
1285   (request-method
1286    (:get ()
1287      (when (hunchentoot:get-parameter "commentId")
1288        (redirect (format nil "~A/comment/~A" (generate-item-link :post post-id) comment-id))
1289        (return))
1290      (let* ((lw2-auth-token *current-auth-token*)
1291             (preview (string-equal format "preview"))
1292             (show-comments (and (not preview) show-comments))
1293             (*enable-voting* (not (null (logged-in-userid)))))
1294        (multiple-value-bind (post title condition)
1295            (handler-case (nth-value 0 (get-post-body post-id :auth-token (and need-auth lw2-auth-token)))
1296              (serious-condition (c)
1297                (setf *enable-voting* nil)
1298                (values nil "[missing post]" c))
1299              (:no-error (post)
1300                (values post (cdr (assoc :title post)) nil)))
1301          (let* ((is-event (cdr (assoc :is-event post)))
1302                 (correct-subtype (if is-event "event" "post")))
1303            (when (string/= post-type correct-subtype)
1304              (redirect (generate-item-link :post post :comment-id comment-id :item-subtype correct-subtype))
1305              (return)))
1306          (labels ((extra-head ()
1307                     (when-let (canonical-source (or (and (not comment-id)
1308                                                          (cdr (assoc :canonical-source post)))
1309                                                     (and (always-canonical *current-site*)
1310                                                          (main-site-link *current-site* :post post-id :slug (cdr (assoc :slug post))
1311                                                                          :comment-id comment-id :direct-comment-link t))))
1312                               <link rel="canonical" href=canonical-source>)
1313                     <script>postId=(with-html-stream-output (:stream stream) (json:encode-json post-id stream))</script>
1314                     <script>alignmentForumPost=(if (cdr (assoc :af post)) "true" "false")</script>
1315                     (when (logged-in-userid)
1316                               (call-with-server-data 'process-vote-data (format nil "/karma-vote/post?post-id=~A" post-id))))
1317                   (retrieve-individual-comment (comment-thread-type)
1318                     (let* ((comments (case comment-thread-type
1319                                        (:comment (get-post-comments post-id))
1320                                        (:answer (get-post-answers post-id))))
1321                            (target-comment (find comment-id comments :key (lambda (c) (cdr (assoc :--id c))) :test #'string=)))
1322                       (values comments target-comment))))
1323            (if comment-id
1324                (let ((comment-thread-type (if (string= comment-link-type "answer") :answer :comment)))
1325                  (multiple-value-bind (comments target-comment) (retrieve-individual-comment comment-thread-type)
1326                    (unless target-comment
1327                      ;; If the comment was not found, try as an answer, or vice versa.
1328                      (setf comment-thread-type (if (eq comment-thread-type :comment) :answer :comment)
1329                            (values comments target-comment) (retrieve-individual-comment comment-thread-type))
1330                      (unless target-comment
1331                        (error 'lw2-not-found-error)))
1332                    (let* ((*comment-individual-link* t)
1333                           (display-name (get-username (cdr (assoc :user-id target-comment))))
1334                           (verb-phrase (cond
1335                                          ((and (eq comment-thread-type :answer)
1336                                                (not (cdr (assoc :parent-comment-id target-comment))))
1337                                           "answers")
1338                                          (t "comments on"))))
1339                      (emit-page (out-stream :title (format nil "~A ~A ~A" display-name verb-phrase title)
1340                                             :content-class "individual-thread-page comment-thread-page"
1341                                             :social-description (when-let (x (cdr (assoc :html-body target-comment))) (extract-excerpt x))
1342                                             :extra-head #'extra-head)
1343                                 (unless preview
1344                                   (format out-stream "<h1 class=\"post-title\">~A ~A <a href=\"~A\">~A</a></h1>"
1345                                           (encode-entities display-name)
1346                                           verb-phrase
1347                                           (generate-item-link :post post-id)
1348                                           (clean-text-to-html title :hyphenation nil)))
1349                                 (output-comments out-stream "comment" comments target-comment :chrono chrono :preview preview)))))
1350                (let ((post-sequences (get-post-sequences post-id)))
1351                  (emit-page (out-stream :title title
1352                                         :content-class (format nil "post-page comment-thread-page~{ ~A~}"
1353                                                                (list-cond ((cdr (assoc :question post)) "question-post-page")
1354                                                                           (post-sequences "in-sequence")
1355                                                                           ((not show-comments) "no-comments")))
1356                                         :social-description (when-let (x (cdr (assoc :html-body post))) (extract-excerpt x))
1357                                         :extra-head #'extra-head)
1358                             (cond
1359                               (condition
1360                                (error-explanation-case (error-to-html condition)
1361                                                        (lw2-not-allowed-error
1362                                                         <p>This probably means the post has been deleted or moved back to the author's drafts.</p>)))
1363                               (t
1364                                (post-body-to-html post)))
1365                             (when (and lw2-auth-token (equal (logged-in-userid) (cdr (assoc :user-id post))))
1366                               (format out-stream "<div class=\"post-controls\"><a class=\"edit-post-link button\" href=\"/edit-post?post-id=~A\" accesskey=\"e\" title=\"Edit post [e]\">Edit post</a></div>"
1367                                       (cdr (assoc :--id post))))
1368                             (alist-bind (fm-crosspost foreign-post) post
1369                               (alist-bind (is-crosspost hosted-here) fm-crosspost
1370                                 (when is-crosspost
1371                                   (if-let (crosspost-site-host (backend-magnum-crosspost-site *current-backend*))
1372                                       (let* ((*current-site* (find-site crosspost-site-host))
1373                                              (crosspost-site-title (main-site-title *current-site*)))
1374                                         (alist-bind (comment-count base-score) foreign-post
1375                                           <a class="crosspost" href=(generate-item-link :post foreign-post :absolute t)>Crossposted (if hosted-here "to" "from") (progn crosspost-site-title)
1376                                                                                                                         \ \((safe (pretty-number (or base-score 0) "point")), (safe (pretty-number (or comment-count 0) "comment"))\)</a>))
1377                                       (error "Could not retrieve crossposted post. magnum-crosspost-site not configured.")))))
1378                             (post-nav-links post post-sequences)
1379                             (activate-client-trigger "postLoaded")
1380                             (when show-comments
1381                               (write-string "<script> </script>" out-stream)
1382                               (finish-output out-stream)
1383                               (with-error-html-block ()
1384                                 ;; Temporary hack to support nominations
1385                                 (let* ((real-comments (get-post-comments post-id))
1386                                        (answers (when (cdr (assoc :question post))
1387                                                   (get-post-answers post-id)))
1388                                        (debate-responses (when (cdr (assoc :debate post))
1389                                                            (get-post-debate-responses post-id)))
1390                                        (posted-at (and (typep *current-backend* 'backend-lw2)
1391                                                        (cdr (assoc :posted-at post))))
1392                                        (posted-timestamp (and posted-at (local-time:parse-timestring posted-at)))
1393                                        (now (local-time:now))
1394                                        (nominations-open nil)
1395                                        (reviews-eligible (timerange "2020-01-01" posted-timestamp "2021-01-01"))
1396                                        (reviews-open (and reviews-eligible (timerange "2021-12-14" now "2022-01-11"))))
1397                                   (labels ((top-level-property (comment property)
1398                                              (or (cdr (assoc property comment))
1399                                                  (cdr (assoc property (cdr (assoc :top-level-comment comment)))))))
1400                                     (multiple-value-bind (normal-comments nominations reviews)
1401                                         (loop for comment in real-comments
1402                                            if (top-level-property comment :nominated-for-review)
1403                                            collect comment into nominations
1404                                            else if (top-level-property comment :reviewing-for-review)
1405                                            collect comment into reviews
1406                                            else
1407                                            collect comment into normal-comments
1408                                            finally (return (values normal-comments nominations reviews)))
1409                                       (unless (or nominations reviews)
1410                                         (setf normal-comments real-comments)) ;for caching
1411                                       (loop for (name comments open) in (list-cond ((or nominations nominations-open)
1412                                                                                     (list "nomination" nominations nominations-open))
1413                                                                                    ((or reviews reviews-open)
1414                                                                                     (list "review" reviews reviews-open))
1415                                                                                    ((cdr (assoc :debate post))
1416                                                                                     (list "debate-responses" debate-responses nil))
1417                                                                                    ((cdr (assoc :question post))
1418                                                                                     (list "answer" answers t))
1419                                                                                    (t
1420                                                                                     (list "comment" normal-comments t)))
1421                                          do (output-comments out-stream name comments nil
1422                                                              :replies-open open
1423                                                              :overcomingbias-sort (cdr (assoc :comment-sort-order post)) :chrono chrono :preview preview))))))))))))))
1424    (:post ()
1425           (post-comment :post-id post-id :need-auth need-auth))))
1426
1427 (defparameter *edit-post-template* (compile-template* "edit-post.html"))
1428
1429 (define-page view-edit-post "/edit-post" (title url section tags post-id link-post)
1430   (request-method
1431     (:get ()
1432      (let* ((csrf-token (make-csrf-token))
1433             (post-body (if post-id (get-post-body post-id :auth-token (hunchentoot:cookie-in "lw2-auth-token"))))
1434             (section (or section (loop for (sym . sec) in '((:draft . "drafts") (:meta . "meta") (:frontpage-date . "frontpage"))
1435                                        if (cdr (assoc sym post-body)) return sec
1436                                        finally (return "all")))))
1437        (emit-page (out-stream :title (if post-id "Edit Post" "New Post") :content-class "edit-post-page")
1438                   (render-template* *edit-post-template* out-stream
1439                                     :csrf-token csrf-token
1440                                     :title (cdr (assoc :title post-body))
1441                                     :url (cdr (assoc :url post-body))
1442                                     :question (cdr (assoc :question post-body))
1443                                     :tags-supported (typep *current-backend* 'backend-accordius)
1444                                     :tags (when (and post-id (typep *current-backend* 'backend-accordius)) (do-wl-rest-query (format nil "posts/~a/update_tagset/" post-id) '()))
1445                                     :post-id post-id
1446                                     :section-list (loop for (name desc) in '(("all" "All") ("meta" "Meta") ("frontpage" "Frontpage") ("drafts" "Drafts"))
1447                                                      when (or (string= name section) (member name '("drafts" "all") :test #'string=))
1448                                                      collect (alist :name name :desc desc :selected (string= name section)))
1449                                     :lesswrong-misc (typep *current-backend* 'backend-lw2-misc-features)
1450                                     :submit-to-frontpage (if post-id (cdr (assoc :submit-to-frontpage post-body)) t)
1451                                     :markdown-source (or (and post-id (markdown-source :post post-id (cdr (assoc :html-body post-body)))) "")))))
1452     (:post (text question submit-to-frontpage)
1453      (let ((lw2-auth-token *current-auth-token*)
1454            (url (if (string= url "") nil url)))
1455        (assert lw2-auth-token)
1456        (let* ((post-data
1457                (list-cond
1458                 (t :body (postprocess-markdown text))
1459                 (t :title (or (nonempty-string title) "Untitled"))
1460                 (link-post :url url)
1461                 (t :meta (or (string= section "meta") :false))
1462                 ((not post-id) :is-event nil)
1463                 (t :draft (or (string= section "drafts") :false))
1464                 ((typep *current-backend* 'backend-lw2-misc-features) :submit-to-frontpage (and submit-to-frontpage t))
1465                 ((not post-id) :question (if question t :false))))
1466               (post-unset
1467                (list-cond
1468                 ((not link-post) :url t)))
1469               (new-post-data
1470                (if post-id
1471                    (do-lw2-post-edit lw2-auth-token post-id post-data post-unset)
1472                    (do-lw2-post lw2-auth-token post-data)))
1473               (new-post-id (cdr (assoc :--id new-post-data))))
1474          (assert new-post-id)
1475          (when (typep *current-backend* 'backend-accordius)
1476            (do-wl-rest-mutate :post
1477              (format nil "posts/~a/update_tagset/" post-id)
1478              (alist "tags" tags)
1479              lw2-auth-token))
1480          (setf (markdown-source :post new-post-id (cdr (assoc :html-body new-post-data))) text)
1481          (ignore-errors (get-post-body post-id :force-revalidate t))
1482          (redirect (if (js-true (cdr (assoc :draft post-data)))
1483                        (concatenate 'string (generate-item-link :post new-post-data) "?need-auth=y")
1484                        (generate-item-link :post new-post-data))))))))
1485
1486 (define-json-endpoint (view-karma-vote forum-site "/karma-vote")
1487     (let ((auth-token *current-auth-token*))
1488       (request-method
1489        (:post (target target-type (vote-json :real-name "vote"))
1490               (let ((vote (safe-decode-json vote-json)))
1491                 (multiple-value-bind (current-vote result)
1492                     (do-lw2-vote auth-token target-type target vote)
1493                   (alist-bind (vote-count base-score af af-base-score extended-score) result
1494                               (let ((vote-buttons (vote-buttons base-score
1495                                                                 :as-text t
1496                                                                 :af-score (and af af-base-score)
1497                                                                 :vote-count (+ vote-count (if (member (cdr (assoc :karma current-vote)) '(nil "neutral") :test #'equal)
1498                                                                                               0
1499                                                                                               1))
1500                                                                 :extended-score extended-score))
1501                                     (out (make-hash-table)))
1502                                 (loop for (axis . axis-vote) in current-vote
1503                                    do (setf (gethash axis out) (list* axis-vote (gethash axis vote-buttons))))
1504                                 out))))))))
1505
1506 (delete-easy-handler 'view-karma-vote)
1507
1508 (define-json-endpoint (view-user-status login-site "/current-user-status")
1509     (let ((auth-token *current-auth-token*))
1510       (request-method
1511        (:get ()
1512              (if (lw2-graphql-query (graphql-query-string "currentUser" nil '(:--id)) :auth-token auth-token)
1513                  (sethash (make-hash-table)
1514                           "notifications" (check-notifications (logged-in-userid) auth-token)
1515                           "alignmentForumAllowed" (member "alignmentForum" (cdr (assoc :groups (get-user :user-id (logged-in-userid)))) :test #'string=))
1516                  (with-cache-transaction
1517                    (cache-del "auth-token-to-userid" auth-token)
1518                    (cache-del "auth-token-to-username" auth-token)))))))
1519
1520 (hunchentoot:define-easy-handler (view-check-notifications :uri "/check-notifications") (format)
1521   (with-error-page
1522       (setf (hunchentoot:content-type*) "application/json")
1523       (if *current-auth-token*
1524           (let ((notifications-status (check-notifications (logged-in-userid) *current-auth-token* :full (string= format "push"))))
1525             (json:encode-json-to-string notifications-status)))))
1526
1527 (hunchentoot:define-easy-handler (view-ignore-user :uri "/ignore-user") ((csrf-token :request-type :post) (target-id :request-type :post) (state :request-type :post) return)
1528   (with-error-page
1529       (check-csrf-token csrf-token)
1530       (let ((user-id (logged-in-userid)))
1531         (unless user-id (error "Not logged in."))
1532         (with-cache-transaction
1533             (let ((ignore-hash (get-ignore-hash user-id)))
1534               (if (string= state "ignore")
1535                   (setf (gethash target-id ignore-hash) t)
1536                   (remhash target-id ignore-hash))
1537               (cache-put "user-ignore-list" user-id ignore-hash :value-type :json))))
1538       (when return
1539         (redirect return))))
1540
1541 (client-defun comment-controls (&key standalone parent-comment-id parent-answer-id edit-comment-id)
1542   (flet ((inner ()
1543            <form method="post" id="conversation-form" class="aligned-form">
1544              <div class="textarea-container">
1545                <textarea name="text" oninput="enableBeforeUnload();"></textarea>
1546                <span class="markdown-reference-link">You can use <a href="http://commonmark.org/help/" target="_blank">Markdown</a> here.</span>
1547                <button type="button" class="guiedit-mobile-auxiliary-button guiedit-mobile-help-button">Help</button>
1548                <button type="button" class="guiedit-mobile-auxiliary-button guiedit-mobile-exit-button">Exit</button>
1549              </div>
1550              <div>
1551                (macrolet ((hidden-var (name)
1552                             `(when ,name <input type="hidden" name=,(string-downcase name) value=,name>)))
1553                  (hidden-var parent-comment-id)
1554                  (hidden-var parent-answer-id)
1555                  (hidden-var edit-comment-id))
1556                <input name="csrf-token" value=(make-csrf-token) type="hidden">
1557                <input value="Submit" type="submit">
1558              </div>
1559              </form>))
1560     (if standalone
1561         <div class="posting-controls standalone with-markdown-editor" onsubmit="disableBeforeUnload();">(with-html-stream-output (inner))</div>
1562         (inner))))
1563
1564 (define-json-endpoint (view-karma-vote-shortform shortform-site "/karma-vote/shortform")
1565   (let ((auth-token *current-auth-token*))
1566     (request-method
1567      (:get ((offset :type fixnum :default 0))
1568            (sethash (make-hash-table)
1569                     "Comment" (get-shortform-votes auth-token :offset offset))))))
1570
1571 (define-component view-comments-index (index-type)
1572   (:http-args ((offset :type fixnum)
1573                (limit :type fixnum)
1574                (view :member '(nil :alignment-forum))))
1575   (request-method
1576    (:get ()
1577      (let* ((want-total (not (or (typep *current-backend* 'backend-lw2) (typep *current-backend* 'backend-ea-forum)))) ; LW2/EAF can't handle total queries. TODO: handle this in backend.
1578             (shortform (eq index-type :shortform))
1579             (with-voting (not (null (and shortform (logged-in-userid))))))
1580        (multiple-value-bind (title query-view top-nav)
1581            (cond
1582              (shortform (values "Shortform" "shortform" (if (logged-in-userid) (lambda () (comment-controls :standalone t)))))
1583              (t (values (case view (:alignment-forum "Alignment Forum recent comments") (t "Recent comments")) "allRecentComments" nil)))
1584          (multiple-value-bind (recent-comments total last-modified)
1585              (if (or (not (eq index-type :recent-comments)) offset limit view (/= (user-pref :items-per-page) 20))
1586                  (let ((*use-alignment-forum* (eq view :alignment-forum)))
1587                    (lw2-graphql-query (lw2-query-string :comment :list
1588                                                         (remove nil (alist :view query-view
1589                                                                            :limit (or limit (user-pref :items-per-page)) :offset offset)
1590                                                                 :key #'cdr)
1591                                                         :context (if shortform :shortform :index)
1592                                                         :with-total want-total)))
1593                  (get-recent-comments :with-total want-total))
1594            (handle-last-modified last-modified)
1595            (renderer ()
1596              (view-items-index recent-comments
1597                                :title title
1598                                :extra-head (lambda ()
1599                                              (when with-voting
1600                                                (call-with-server-data 'process-vote-data (format nil "/karma-vote/shortform?offset=~A" (or offset 0)))))
1601                                :content-class (if shortform "index-page shortform-index-page comment-thread-page" "index-page comment-index-page")
1602                                :pagination (pagination-nav-bars :offset (or offset 0) :with-next (not want-total) :total (if want-total total))
1603                                :top-nav (lambda () (page-toolbar-to-html :title title) (when top-nav (funcall top-nav)))
1604                                :alternate-html (if (eq index-type :shortform)
1605                                                    (lambda ()
1606                                                      (let ((*enable-voting* with-voting))
1607                                                        <div class="comments">
1608                                                          (comment-tree-to-html *html-output*
1609                                                                                (make-comment-parent-hash
1610                                                                                 (flatten-shortform-comments recent-comments)))
1611                                                        </div>)))))))))
1612    (:post ()
1613      (post-comment :shortform t))))
1614
1615 (define-component-routes forum-site (view-recent-comments (standard-route :uri "/recentcomments") () (view-comments-index :recent-comments)))
1616 (define-component-routes shortform-site (view-shortform (standard-route :uri "/shortform") () (view-comments-index :shortform)))
1617
1618 (delete-easy-handler 'view-recent-comments)
1619
1620 (defun tag-to-html (tag &key skip-headline)
1621   (schema-bind (:tag tag :auto :context :body)
1622     (alist-bind (edited-at html user-id) description
1623       (unless skip-headline
1624         <h1 class="post-title">(safe (clean-text-to-html name))</h1>
1625         <div class="post-meta">
1626           <span>(if core "Core ")(if wiki-only "Wiki" "Tag")</span>
1627           (when (and (nonempty-string edited-at) (nonempty-string user-id))
1628             <span>Last edit: (pretty-time-html edited-at)
1629                   \ by <a class="author" href=("/users/~A" (get-user-slug user-id))>(get-username user-id)</a>
1630             </span>)
1631         </div>)
1632       (when html
1633         <div class="tag-description body-text">(with-html-stream-output (:stream stream) (let ((*memoized-output-stream* stream)) (clean-html* html)))</div>))))
1634
1635 (defun tag-list-to-html (tags)
1636   <ul class="tag-list">
1637     (iter (for tag in tags)
1638           (schema-bind (:tag tag :auto :context :index)
1639                        <li><a class="post-title-link" href=("/tag/~A" slug)>(safe (clean-text-to-html name))(if wiki-only
1640                                                                                                                 " (wiki)"
1641                                                                                                                 (if post-count (format nil " (~A)" post-count)))</a></li>))
1642   </ul>)
1643
1644 (define-json-endpoint (view-user-autocomplete forum-site "/-user-autocomplete")
1645     (request-method
1646      (:get (q)
1647           (lw2-search-query q :indexes '(:users)))))
1648
1649 (define-json-endpoint (view-karma-vote-tag forum-site "/karma-vote/tag")
1650   (let ((auth-token *current-auth-token*))
1651     (request-method
1652      (:get (tag-id post-id)
1653        (hash-cond (make-hash-table)
1654          (tag-id "Post" (get-tag-post-votes tag-id auth-token))
1655          (tag-id "Comment" (get-tag-comments-votes tag-id auth-token))
1656          (post-id "Tag" (get-post-tag-votes post-id auth-token)))))))
1657
1658 (define-component view-tag (slug tail)
1659   (:http-args ((sort :default :relevant :member '(:relevant :new :old))))
1660   (when (nonempty-string tail)
1661     (redirect (format nil "/tag/~A" slug))
1662     (return))
1663   (let ((tag (first (lw2-graphql-query (lw2-query-string :tag :list (alist :view "tagBySlug" :slug slug) :context :body)))))
1664     (unless tag
1665       (error 'lw2-not-found-error))
1666     (request-method
1667      (:get ()
1668        (let* ((posts (get-tag-posts slug))
1669               (posts (if (eq sort :relevant) posts (sort-items posts sort))))
1670          (schema-bind (:tag tag :auto :context :body)
1671            (renderer ()
1672              (view-items-index posts
1673                                :title (format nil "~A tag" name)
1674                                :extra-head (lambda ()
1675                                              (when-let (canonical-source (and (always-canonical *current-site*)
1676                                                                               (main-site-link *current-site* :tag slug)))
1677                                                <link rel="canonical" href=canonical-source>)
1678                                              (when (logged-in-userid)
1679                                                (call-with-server-data 'process-vote-data (format nil "/karma-vote/tag?tag-id=~A" tag-id))))
1680                                :top-nav (lambda ()
1681                                           (page-toolbar-to-html :title name :rss (not wiki-only))
1682                                           (tag-to-html tag)
1683                                           (when (and posts (not *preview*))
1684                                             (sublevel-nav-to-html '(:relevant :new :old)
1685                                                                   sort
1686                                                                   :default :relevant
1687                                                                   :param-name "sort"
1688                                                                   :extra-class "sort")))
1689                                :content-class "index-page tag-index-page"
1690                                :alternate-html (lambda ()
1691                                                  (unless wiki-only
1692                                                    (write-index-items-to-html *html-output* posts))
1693                                                  (when (typep *current-backend* 'backend-lw2-tags-comments)
1694                                                    (finish-output *html-output*)
1695                                                    (let ((*enable-voting* (not (null (logged-in-userid))))
1696                                                          (comments (lw2-graphql-query (lw2-query-string :comment :list (alist :view "tagDiscussionComments" :tag-id tag-id)))))
1697                                                      (output-comments *html-output* "comment" comments nil :replies-open t)))))))))
1698      (:post ()
1699        (schema-bind (:tag tag (tag-id))
1700          (renderer ()
1701            (post-comment :tag-id tag-id)))))))
1702
1703 (define-component-routes forum-site (view-tag (regex-route :regex "^/(?:tag|topics)/([^/?]+)(/[^/?]*)?") (slug tail) (view-tag slug tail)))
1704
1705 (define-route 'ea-forum-viewer-site 'regex-route :name 'view-tags-redirect :regex "^/tag/" :handler (lambda () (redirect (ppcre:regex-replace "^/tag/" (hunchentoot:request-uri*) "/topics/"))))
1706
1707 (define-component view-tags-index ()
1708   (:http-args ())
1709   (multiple-value-bind (all-tags portal)
1710       (lw2-graphql-query-multi
1711        (list (lw2-query-string* :tag :list (alist :view "allTagsAlphabetical"))
1712              (lw2-query-string* :tag :list (alist :view "tagBySlug" :slug "portal") :context :body)))
1713     (let ((core-tags
1714            (iter (for tag in all-tags)
1715                  (schema-bind (:tag tag (core))
1716                               (when core (collect tag)))))
1717           (title (if (typep *current-site* 'lesswrong-viewer-site) "Concepts Portal" "Tags Portal")))
1718       (renderer ()
1719         (emit-page (out-stream :title title)
1720           <article>
1721             <h1 class="post-title">(safe title)</h1>
1722             (tag-to-html (first portal) :skip-headline t)
1723           </article>
1724           (iter (for (title . tags) in (alist "Core Tags" core-tags "All Tags" all-tags))
1725                 (progn
1726                   <h1>(safe title)</h1>
1727                   (tag-list-to-html tags))))))))
1728
1729 (define-component-routes forum-site (view-tags-index (standard-route :uri "/tags") () (view-tags-index)))
1730 (define-component-routes forum-site (view-tags-index-alt (standard-route :uri "/topics") () (view-tags-index)))
1731
1732 (define-route 'forum-site 'standard-route :name 'view-tags-index-redirect :uri "/tags/all" :handler (lambda () (redirect "/tags")))
1733 (define-route 'forum-site 'standard-route :name 'view-tags-index-redirect :uri "/topics/all" :handler (lambda () (redirect "/topics")))
1734
1735 (define-route 'alternate-frontend-site 'standard-route :name 'view-tags-voting-redirect :uri "/tagVoting" :handler (lambda () (main-site-redirect "/tagVoting")))
1736 (define-route 'alternate-frontend-site 'standard-route :name 'view-tags-dashboard-redirect :uri "/tags/dashboard" :handler (lambda () (main-site-redirect "/tags/dashboard")))
1737
1738 (hunchentoot:define-easy-handler (view-push-register :uri "/push/register") ()
1739   (with-error-page
1740       (let* ((data (call-with-safe-json (lambda ()
1741                                           (json:decode-json-from-string
1742                                            (hunchentoot:raw-post-data :force-text t :external-format :utf-8)))))
1743              (subscription (cdr (assoc :subscription data)))
1744              (cancel (cdr (assoc :cancel data))))
1745         (cond
1746           (subscription
1747            (make-subscription *current-auth-token*
1748                               (cdr (assoc :endpoint subscription))
1749                               (cdr (assoc :expires *current-auth-status*)))
1750            (send-notification (cdr (assoc :endpoint subscription)) :ttl 120))
1751           (cancel
1752            (delete-subscription *current-auth-token*)))
1753         nil)))
1754
1755 (hunchentoot:define-easy-handler (view-inbox-redirect :uri "/push/go-inbox") ()
1756   (with-error-page
1757       (redirect (format nil "/users/~A?show=inbox" *current-user-slug*))))
1758
1759 (define-page view-user (:regex "^/users/(.*?)(?:$|\\?)|^/user" user-slug) (id
1760                                                                              (offset :type fixnum :default 0)
1761                                                                              (show :member '(:all :posts :comments :drafts :conversations :inbox) :default :all)
1762                                                                              (sort :member '(:top :new :old) :default :new))
1763              (let* ((auth-token (if (eq show :inbox) *current-auth-token*))
1764                     (user-info
1765                      (let ((ui (get-user (cond (user-slug :user-slug) (id :user-id)) (or user-slug id) :auth-token auth-token)))
1766                        (if (and (not (cdr (assoc :deleted ui))) (cdr (assoc :--id ui)))
1767                            ui
1768                            (error 'lw2-user-not-found-error))))
1769                     (user-id (cdr (assoc :--id user-info)))
1770                     (own-user-page (logged-in-userid user-id))
1771                     (display-name (if user-slug (cdr (assoc :display-name user-info)) user-id))
1772                     (show-text (if (not (eq show :all)) (string-capitalize show)))
1773                     (title (format nil "~A~@['s ~A~]" display-name show-text))
1774                     (sort-type (case sort (:top :score) (:new :date) (:old :date-reverse))))
1775                (multiple-value-bind (items total last-modified)
1776                  (case show
1777                    (:posts
1778                     (get-user-page-items user-id :posts :offset offset :limit (+ 1 (user-pref :items-per-page)) :sort-type sort-type))
1779                    (:comments
1780                     (get-user-page-items user-id :comments :offset offset :limit (+ 1 (user-pref :items-per-page)) :sort-type sort-type))
1781                    (:drafts
1782                     (get-user-page-items user-id :posts :drafts t :offset offset :limit (+ 1 (user-pref :items-per-page)) :auth-token (hunchentoot:cookie-in "lw2-auth-token")))
1783                    (:conversations
1784                      (let ((conversations
1785                              (lw2-graphql-query (lw2-query-string :conversation :list
1786                                                                   (alist :view "userConversations" :limit (+ 1 (user-pref :items-per-page)) :offset offset :user-id user-id)
1787                                                                   :fields '(:--id :created-at :title (:participants :display-name :slug) :----typename))
1788                                                 :auth-token (hunchentoot:cookie-in "lw2-auth-token"))))
1789                        (lw2-graphql-query-map
1790                          (lambda (c)
1791                            (lw2-query-string* :message :total (alist :view "messagesConversation" :conversation-id (cdr (assoc :--id c)))))
1792                          conversations
1793                          :postprocess (lambda (c result)
1794                                         (acons :messages-total result c))
1795                          :auth-token (hunchentoot:cookie-in "lw2-auth-token"))))
1796                    (:inbox
1797                     (error-explanation-case
1798                      (prog1
1799                        (let ((notifications (get-notifications :user-id user-id :offset offset :auth-token (hunchentoot:cookie-in "lw2-auth-token")))
1800                              (last-check (ignore-errors (local-time:parse-timestring (cdr (assoc :last-notifications-check user-info))))))
1801                          (labels ((check-new (key obj)
1802                                     (if (ignore-errors (local-time:timestamp< last-check (local-time:parse-timestring (cdr (assoc key obj)))))
1803                                         (acons :highlight-new t obj)
1804                                         obj))
1805                                   (check-replied (comment)
1806                                     (let* ((post-id (cdr (assoc :post-id comment)))
1807                                            (comment-id (cdr (assoc :--id comment)))
1808                                            (reply-comment-id (check-comment-replied comment-id user-id)))
1809                                       (if reply-comment-id
1810                                           (acons :replied (list :post post-id :comment-id reply-comment-id) comment)
1811                                           comment))))
1812                            (lw2-graphql-query-map
1813                              (lambda (n)
1814                                (alexandria:switch ((cdr (assoc :document-type n)) :test #'string=)
1815                                                   ("comment"
1816                                                    (lw2-query-string* :comment :single
1817                                                                       (alist :document-id (cdr (assoc :document-id n)))
1818                                                                       :context :index))
1819                                                   ("post"
1820                                                    (lw2-query-string* :post :single (alist :document-id (cdr (assoc :document-id n)))))
1821                                                   ("message"
1822                                                    (lw2-query-string* :message :single (alist :document-id (cdr (assoc :document-id n)))
1823                                                                       :fields *messages-index-fields*))
1824                                                   (t
1825                                                     (values n t))))
1826                              notifications
1827                              :postprocess (lambda (n result)
1828                                             (if result
1829                                                 (funcall (if (string= (cdr (assoc :document-type n)) "comment") #'check-replied #'identity)
1830                                                          (check-new
1831                                                           (alexandria:switch ((cdr (assoc :document-type n)) :test #'string=)
1832                                                                              ("comment" :posted-at)
1833                                                                              ("post" :posted-at)
1834                                                                              ("message" :created-at))
1835                                                           result))
1836                                                 n))
1837                              :auth-token auth-token)))
1838                        (do-user-edit
1839                          (hunchentoot:cookie-in "lw2-auth-token")
1840                          user-id
1841                          (alist :last-notifications-check (timestamp-to-graphql (local-time:now)))))
1842                      (lw2-not-allowed-error
1843                       <p>This may mean your login token has expired or become invalid. You can try <a href="/login">logging in again</a>.</p>)))
1844                    (t
1845                     (get-user-page-items user-id :both :offset offset :limit (+ 1 (user-pref :items-per-page)) :sort-type sort-type)))
1846                  (handle-last-modified last-modified)
1847                  (let ((with-next (> (length items) (+ (if (eq show :all) offset 0) (user-pref :items-per-page))))
1848                        (interleave (if (eq show :all) (comment-post-interleave items :limit (user-pref :items-per-page) :offset (if (eq show :all) offset nil) :sort-by sort-type) (firstn items (user-pref :items-per-page))))) ; this destructively sorts items
1849                    (view-items-index interleave :title title
1850                                      :content-class (format nil "user-page~@[ ~A-user-page~]~:[~; own-user-page~]" (string-downcase show) own-user-page)
1851                                      :current-uri (format nil "/users/~A" user-slug)
1852                                      :section :personal
1853                                      :pagination (pagination-nav-bars :offset offset :total total :with-next (if (not total) with-next))
1854                                      :need-auth (eq show :drafts) :section (if (eq show :drafts) "drafts" nil)
1855                                      :top-nav (lambda ()
1856                                                 (page-toolbar-to-html :title title
1857                                                                       :enable-push-notifications (eq show :inbox)
1858                                                                       :rss (not (member show '(:drafts :conversations :inbox)))
1859                                                                       :new-post (if (eq show :drafts) "drafts" t)
1860                                                                       :new-conversation (if own-user-page t user-slug)
1861                                                                       :ignore (if (and (logged-in-userid) (not own-user-page))
1862                                                                                   (lambda ()
1863                                                                                     (let ((ignored (gethash user-id *current-ignore-hash*)))
1864                                                                                       <form method="post" action="/ignore-user">
1865                                                                                         <button class=("button ~A" (if ignored "unignore-button" "ignore-button"))>(if ignored "Unignore user" "Ignore user")</button>
1866                                                                                         <input type="hidden" name="csrf-token" value=(make-csrf-token)>
1867                                                                                         <input type="hidden" name="target-id" value=user-id>
1868                                                                                         <input type="hidden" name="state" value=(if ignored "unignore" "ignore")>
1869                                                                                         <input type="hidden" name="return" value=(hunchentoot:request-uri*)>
1870                                                                                       </form>)))
1871                                                                       :logout own-user-page)
1872                                                 (alist-bind ((actual-id string :--id)
1873                                                              (actual-slug string :slug)
1874                                                              (karma (or null fixnum))
1875                                                              (af-karma (or null fixnum)))
1876                                                             user-info
1877                                                   <h1 class="page-main-heading"
1878                                                       (when (not own-user-page)
1879                                                         (format nil "data-~:[~;anti-~]~:*kibitzer-redirect=~:[/users/~*~A~;/user?id=~A~]"
1880                                                                 user-slug actual-id actual-slug))>
1881                                                       (progn display-name)
1882                                                       (let ((full-name (get-user-full-name user-id)))
1883                                                         (when (and user-slug (stringp full-name) (> (length full-name) 0))
1884                                                                   <span class="user-full-name">\((progn full-name)\)</span>))
1885                                                   </h1>
1886                                                   <div class="user-stats">
1887                                                     Karma:
1888                                                     <span class="karma-type">
1889                                                       <span class="karma-total">(if user-slug (pretty-number (or karma 0)) "##")</span>(if af-karma " (LW),")
1890                                                     </span>\
1891                                                     (when af-karma
1892                                                       <span class="karma-type">
1893                                                         <span class="karma-total af-karma-total">(if user-slug (pretty-number (or af-karma 0)) "##")</span> \(AF\)
1894                                                       </span>)
1895                                                   </div>
1896                                                   (when-let (html-bio (cdr (assoc :html-bio user-info)))
1897                                                     <div class="user-bio body-text">
1898                                                       (with-html-stream-output (:stream stream)
1899                                                         (let ((*memoized-output-stream* stream))
1900                                                           (clean-html* html-bio)))
1901                                                     </div>))
1902                                                 (sublevel-nav-to-html `(:all :posts :comments
1903                                                                              ,@(if own-user-page
1904                                                                                    '(:drafts :conversations :inbox)))
1905                                                                       show
1906                                                                       :default :all)
1907                                                 (when (member show '(:all :posts :comments))
1908                                                   (sublevel-nav-to-html '(:new :top :old)
1909                                                                         sort
1910                                                                         :default :new
1911                                                                         :param-name "sort"
1912                                                                         :extra-class "sort"))))))))
1913
1914 (defparameter *conversation-template* (compile-template* "conversation.html"))
1915
1916 (define-page view-conversation "/conversation" (id to subject)
1917   (request-method
1918    (:get ()
1919      (cond
1920        ((and id to) (error "This is an invalid URL."))
1921        (id
1922         (multiple-value-bind (conversation messages)
1923             (get-conversation-messages id (hunchentoot:cookie-in "lw2-auth-token"))
1924           (let ((conversation (rectify-conversation conversation)))
1925             (view-items-index (nreverse messages) :content-class "conversation-page" :need-auth t :title (encode-entities (cdr (assoc :title conversation)))
1926                               :top-nav (lambda () (render-template* *conversation-template* *html-output*
1927                                                                     :conversation conversation :csrf-token (make-csrf-token)))))))
1928        (t
1929         (emit-page (out-stream :title "New conversation" :content-class "conversation-page")
1930                    (render-template* *conversation-template* out-stream
1931                                      :to to
1932                                      :subject subject
1933                                      :csrf-token (make-csrf-token))))))
1934    (:post ((text :required t))
1935      (let* ((id (or id
1936                     (let ((participant-ids (list (logged-in-userid) (cdar (lw2-graphql-query (lw2-query-string :user :single (alist :slug to) :fields '(:--id)))))))
1937                       (do-create-conversation (hunchentoot:cookie-in "lw2-auth-token") (alist :participant-ids participant-ids :title subject))))))
1938        (do-create-message (hunchentoot:cookie-in "lw2-auth-token") id text)
1939        (redirect (format nil "/conversation?id=~A" id))))))
1940
1941 (define-page view-search "/search" ((q :required t)
1942                                     (sort :default :relevant :member '(:relevant :new :old)))
1943   (let ((*current-search-query* q)
1944         (link (presentable-link q :search))
1945         (title (format nil "~@[~A - ~]Search" q)))
1946     (declare (special *current-search-query*))
1947     (if link
1948         (redirect link)
1949         (multiple-value-bind (results tags) (lw2-search-query q)
1950           (let* ((sort (if (string= (hunchentoot:get-parameter "format") "rss")
1951                            :new
1952                            sort))
1953                  (results (if (eq sort :relevant)
1954                               results
1955                               (sort-items results sort)))
1956                  (results (if (hunchentoot:get-parameter "format")
1957                               (firstn results 20)
1958                               results)))
1959             (view-items-index results
1960                               :top-nav (lambda ()
1961                                          (page-toolbar-to-html :title title :rss t)
1962                                          (sublevel-nav-to-html '(:relevant :new :old)
1963                                                                sort
1964                                                                :default :relevant
1965                                                                :param-name "sort"
1966                                                                :extra-class "sort")
1967                                          (when tags
1968                                            <h1>Tags</h1>
1969                                            (tag-list-to-html (firstn tags 20))))
1970                               :content-class "index-page search-results-page" :current-uri "/search"
1971                               :title title))))))
1972
1973 (defgeneric view-login (backend))
1974
1975 (defmethod view-login ((backend backend-password-login))
1976   (with-http-args (return cookie-check
1977                       (login-username :request-type :post) (login-password :request-type :post)
1978                       (signup-username :request-type :post) (signup-email :request-type :post) (signup-password :request-type :post) (signup-password2 :request-type :post))
1979     (labels
1980         ((emit-login-page (&key error-message)
1981            (let ((csrf-token (make-csrf-token)))
1982              (emit-page (out-stream :title "Log in" :current-uri "/login" :content-class "login-page" :robots "noindex, nofollow")
1983                (when error-message
1984                  (format out-stream "<div class=\"error-box\">~A</div>" error-message))
1985                (with-outputs (out-stream) "<div class=\"login-container\">")
1986                (output-form out-stream "post" (format nil "/login~@[?return=~A~]" (if return (url-rewrite:url-encode return))) "login-form" "Log in" csrf-token
1987                             '(("login-username" "Username" "text" "username")
1988                               ("login-password" "Password" "password" "current-password"))
1989                             "Log in"
1990                             :end-html (when (typep *current-backend* 'backend-websocket-login) ;other backends not supported yet
1991                                         "<a href=\"/reset-password\">Forgot password</a>"))
1992                (output-form out-stream "post" (format nil "/login~@[?return=~A~]" (if return (url-rewrite:url-encode return))) "signup-form" "Create account" csrf-token
1993                             '(("signup-username" "Username" "text" "username")
1994                               ("signup-email" "Email" "text" "email")
1995                               ("signup-password" "Password" "password" "new-password")
1996                               ("signup-password2" "Confirm password" "password" "new-password"))
1997                             "Create account")
1998                (if-let (main-site-title (main-site-title *current-site*))
1999                        (format out-stream "<div class=\"login-tip\"><span>Tip:</span> You can log in with the same username and password that you use on ~A~:*. Creating an account here also creates one on ~A.</div>"
2000                                main-site-title))
2001                (format out-stream "</div>"))))
2002          (finish-login (username user-id auth-token error-message &optional expires)
2003            (cond
2004              (auth-token
2005               (set-cookie "lw2-auth-token" auth-token :max-age (if expires (+ (- expires (get-unix-time)) (* 24 60 60)) (1- (expt 2 31))))
2006               (if expires (set-cookie "lw2-status" (json:encode-json-to-string (alist :expires expires))))
2007               (cache-put "auth-token-to-userid" auth-token user-id)
2008               (cache-put "auth-token-to-username" auth-token username)
2009               (redirect (if (and return (ppcre:scan "^/[^/]" return)) return "/")))
2010              (t
2011               (emit-login-page :error-message error-message)))))
2012       (cond
2013         ((not (or cookie-check (hunchentoot:cookie-in "session-token")))
2014          (set-cookie "session-token" (base64:usb8-array-to-base64-string (ironclad:make-random-salt)))
2015          (redirect (format nil "/login?~@[return=~A&~]cookie-check=y" (if return (url-rewrite:url-encode return)))))
2016         (cookie-check
2017          (if (hunchentoot:cookie-in "session-token")
2018              (redirect (format nil "/login~@[?return=~A~]" (if return (url-rewrite:url-encode return))))
2019              (emit-page (out-stream :title "Log in" :current-uri "/login")
2020                         (format out-stream "<h1>Enable cookies</h1><p>Please enable cookies in your browser and <a href=\"/login~@[?return=~A~]\">try again</a>.</p>" (if return (url-rewrite:url-encode return))))))
2021         (login-username
2022          (cond
2023            ((or (string= login-username "") (string= login-password "")) (emit-login-page :error-message "Please enter a username and password"))
2024            ((lw2.dnsbl:dnsbl-check (hunchentoot:real-remote-addr)) (emit-login-page :error-message "Your IP address is blacklisted."))
2025            (t (multiple-value-call #'finish-login login-username (do-login login-username login-password)))))
2026         (signup-username
2027          (cond
2028            ((not (every (lambda (x) (not (string= x ""))) (list signup-username signup-email signup-password signup-password2)))
2029             (emit-login-page :error-message "Please fill in all fields"))
2030            ((not (string= signup-password signup-password2))
2031             (emit-login-page :error-message "Passwords do not match"))
2032            ((lw2.dnsbl:dnsbl-check (hunchentoot:real-remote-addr)) (emit-login-page :error-message "Your IP address is blacklisted."))
2033            (t (multiple-value-call #'finish-login signup-username (do-lw2-create-user signup-username signup-email signup-password)))))
2034         (t
2035          (emit-login-page))))))
2036
2037 (defmethod view-logout ((backend backend-password-login))
2038   (request-method
2039    (:post ()
2040      (set-cookie "lw2-auth-token" "" :max-age 0)
2041      (do-logout *current-auth-token*)
2042      (redirect "/"))))
2043
2044 (defparameter *reset-password-template* (compile-template* "reset-password.html"))
2045
2046 (define-component basic-reset-password ()
2047   (:http-args ((email :request-type :post) (reset-link :request-type :post) (password :request-type :post) (password2 :request-type :post)))
2048   (renderer ()
2049     (labels ((emit-rpw-page (&key message message-type step)
2050                (let ((csrf-token (make-csrf-token)))
2051                  (emit-page (out-stream :title "Reset password" :content-class "reset-password" :robots "noindex, nofollow")
2052                             (render-template* *reset-password-template* out-stream
2053                                               :csrf-token csrf-token
2054                                               :reset-link reset-link
2055                                               :message message
2056                                               :message-type message-type
2057                                               :step step)))))
2058       (cond
2059         (email
2060          (multiple-value-bind (ret error)
2061              (do-lw2-forgot-password email)
2062            (declare (ignore ret))
2063            (if error
2064                (emit-rpw-page :step 1 :message error :message-type "error")
2065                (emit-rpw-page :step 1 :message "Password reset email sent." :message-type "success"))))
2066         (reset-link
2067          (ppcre:register-groups-bind (reset-token) ("(?:reset-password/|^)([^/#]+)$" reset-link)
2068                                      (cond
2069                                        ((not reset-token)
2070                                         (emit-rpw-page :step 2 :message "Invalid password reset link." :message-type "error"))
2071                                        ((not (string= password password2))
2072                                         (emit-rpw-page :step 2 :message "Passwords do not match." :message-type "error"))
2073                                        (t
2074                                         (multiple-value-bind (user-id auth-token error-message) (do-lw2-reset-password reset-token password)
2075                                           (declare (ignore user-id auth-token))
2076                                           (cond
2077                                             (error-message (emit-rpw-page :step 2 :message error-message :message-type "error"))
2078                                             (t
2079                                              (with-error-page (emit-page (out-stream :title "Reset password" :content-class "reset-password")
2080                                                                          (format out-stream "<h1>Password reset complete</h1><p>You can now <a href=\"/login\">log in</a> with your new password.</p>"))))))))))
2081         (t
2082          (emit-rpw-page))))))
2083
2084 (define-route 'login-site 'standard-route :name 'view-login :uri "/login" :handler (lambda () (with-error-page (view-login *current-backend*))))
2085 (define-route 'login-site 'standard-route :name 'view-login-oauth2.0-callback :uri "/auth/callback" :handler (lambda () (with-error-page (view-login-oauth2.0-callback *current-backend*))))
2086
2087 (define-route 'login-site 'standard-route :name 'view-logout :uri "/logout" :handler (lambda () (with-error-page (view-logout *current-backend*))))
2088
2089 (define-component-routes login-site
2090     (basic-reset-password (standard-route :uri "/reset-password") () (basic-reset-password)))
2091
2092 (defun oauth2.0-login-request-uri (backend path &optional query)
2093   (quri:render-uri
2094    (quri:merge-uris
2095     (quri:make-uri :path path :query query)
2096     (quri:uri (oauth2.0-login-uri backend)))))
2097
2098 (defmethod view-login ((backend backend-oauth2.0-login))
2099   (with-http-args (return)
2100     (set-cookie "session-token" (base64:usb8-array-to-base64-string (ironclad:make-random-salt)))
2101     (redirect
2102      (oauth2.0-login-request-uri backend "authorize"
2103                                  (alist "response_type" "code"
2104                                         "client_id" (oauth2.0-client-id backend)
2105                                         "redirect_uri" (quri:render-uri (quri:merge-uris (quri:uri "/auth/callback") (quri:uri (site-uri *current-site*))))
2106                                         "scope" "openid profile email"
2107                                         "state" return)))))
2108
2109 (defmethod view-login-oauth2.0-callback ((backend backend-oauth2.0-login))
2110   (with-http-args (code state)
2111     (let ((auth-response
2112            (call-with-http-response #'json:decode-json
2113                                     (oauth2.0-login-request-uri backend "oauth/token")
2114                                     :method :post
2115                                     :content (alist "grant_type" "authorization_code"
2116                                                     "client_id" (oauth2.0-client-id backend)
2117                                                     "client_secret" (oauth2.0-client-secret backend)
2118                                                     "code" code
2119                                                     "redirect_uri" (quri:render-uri (quri:merge-uris (quri:uri "/auth/callback") (quri:uri (site-uri *current-site*)))))
2120                                     :want-stream t :force-string t)))
2121       (alist-bind ((access-token (or null simple-string) :access--token)
2122                    (error (or null simple-string))
2123                    (error-description (or null simple-string) :error--description))
2124                   auth-response
2125                   (when error
2126                     (error "Login error: ~A" (cdr (assoc :error--description auth-response))))
2127                   (unless access-token
2128                     (error "Login error: server did not provide an access token."))
2129                   (let ((auth-token (do-login-with-oidc-access-token access-token)))
2130                     (alist-bind ((user-id simple-string :--id)
2131                                  (username simple-string :display-name))
2132                                 (do-lw2-post-query
2133                                     auth-token (alist "query"
2134                                                       (graphql-query-string :current-user nil '(:--id :display-name))))
2135                                 (cache-put "auth-token-to-userid" auth-token user-id)
2136                                 (cache-put "auth-token-to-username" auth-token username))
2137                     (set-cookie "lw2-auth-token" auth-token :max-age (1- (expt 2 31)))
2138                     (redirect (if (and state (ppcre:scan "^/[^/]" state)) state "/")))))))
2139
2140 (defmethod view-logout ((backend backend-oauth2.0-login))
2141   (request-method
2142    (:post ()
2143           (set-cookie "lw2-auth-token" "" :max-age 0)
2144           (redirect
2145            (oauth2.0-login-request-uri backend "v2/logout" (alist "client_id" (oauth2.0-client-id backend)))))))
2146
2147 (delete-easy-handler 'view-login)
2148 (delete-easy-handler 'view-logout)
2149 (delete-easy-handler 'view-reset-password)
2150
2151 (define-page view-library "/library"
2152                             ((view :member '(:featured :community) :default :featured))
2153   (let ((sequences
2154          (lw2-graphql-query
2155           (lw2-query-string :sequence :list
2156                             (alist :view (case view
2157                                            (:featured "curatedSequences")
2158                                            (:community "communitySequences")))
2159                             :fields '(:--id :created-at :user-id :title :----typename)))))
2160     (view-items-index
2161      sequences
2162      :title "Sequences Library"
2163      :content-class "sequences-page"
2164      :current-uri "/library"
2165      :top-nav (lambda ()
2166                 (sublevel-nav-to-html '(:featured :community)
2167                                       view
2168                                       :default :featured
2169                                       :param-name "view"
2170                                       :extra-class "sequences-view")))))
2171
2172 (define-page view-sequence (:regex "^/s(?:equences)?/([^/?#]+)(?:/?$|\\?)" sequence-id) ()
2173   (let ((sequence (get-sequence sequence-id)))
2174     (alist-bind ((title string))
2175                 sequence
2176       (emit-page (out-stream
2177                   :title title
2178                   :content-class "sequence-page")
2179                  (sequence-to-html sequence)))))
2180
2181 (define-component view-collection (collection-id) ()
2182                   (let ((collection (get-collection collection-id)))
2183                     (renderer ()
2184                               (emit-page (out-stream :title (cdr (assoc :title collection)) :content-class "sequence-page collection-page")
2185                                          (collection-to-html collection)))))
2186
2187 (define-component-routes lesswrong-viewer-site (view-sequences (standard-route :uri "/sequences") () (view-collection "oneQyj4pw77ynzwAF")))
2188 (define-component-routes lesswrong-viewer-site (view-codex (standard-route :uri "/codex") () (view-collection "2izXHCrmJ684AnZ5X")))
2189 (define-component-routes lesswrong-viewer-site (view-hpmor (standard-route :uri "/hpmor") () (view-collection "ywQvGBSojSQZTMpLh")))
2190 (define-component-routes ea-forum-viewer-site (view-handbook (standard-route :uri "/handbook") () (view-collection "MobebwWs2o86cS9Rd")))
2191
2192 (define-component-routes forum-site (view-tags-index (standard-route :uri "/tags") () (view-tags-index)))
2193
2194 (define-page view-archive (:regex "^/archive(?:/(\\d{4})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))"
2195                            (year :type (mod 10000))
2196                            (month :type (integer 1 12))
2197                            (day :type (integer 1 31)))
2198              ((offset :type fixnum :default 0))
2199   (local-time:with-decoded-timestamp (:day current-day :month current-month :year current-year :timezone local-time:+utc-zone+) (local-time:now)
2200     (local-time:with-decoded-timestamp (:day earliest-day :month earliest-month :year earliest-year :timezone local-time:+utc-zone+) (earliest-post-time)
2201       (labels ((url-elements (&rest url-elements)
2202                  (declare (dynamic-extent url-elements))
2203                  (format nil "/~{~A~^/~}" url-elements))
2204                (archive-nav ()
2205                  (let ((out-stream *html-output*))
2206                    (with-outputs (out-stream) "<div class=\"archive-nav\"><div class=\"archive-nav-years\">")
2207                    (link-if-not out-stream (not (or year month day)) (url-elements "archive") "archive-nav-item-year" "All")
2208                    (loop for y from earliest-year to current-year
2209                       do (link-if-not out-stream (eq y year) (url-elements "archive" y) "archive-nav-item-year" y))
2210                    (format out-stream "</div>")
2211                    (when year
2212                      (format out-stream "<div class=\"archive-nav-months\">")
2213                      (link-if-not out-stream (not month) (url-elements "archive" year) "archive-nav-item-month" "All")
2214                      (loop for m from (if (= (or year current-year) earliest-year) earliest-month 1) to (if (= (or year current-year) current-year) current-month 12)
2215                         do (link-if-not out-stream (eq m month) (url-elements "archive" (or year current-year) m) "archive-nav-item-month" (elt local-time:+short-month-names+ m)))
2216                      (format out-stream "</div>"))
2217                    (when month
2218                      (format out-stream "<div class=\"archive-nav-days\">")
2219                      (link-if-not out-stream (not day) (url-elements "archive" year month) "archive-nav-item-day" "All")
2220                      (loop for d from (if (and (= (or year current-year) earliest-year) (= (or month current-month) earliest-month)) earliest-day 1)
2221                         to (if (and (= (or year current-year) current-year) (= (or month current-month) current-month)) current-day (local-time:days-in-month (or month current-month) (or year current-year)))
2222                         do (link-if-not out-stream (eq d day) (url-elements "archive" (or year current-year) (or month current-month) d) "archive-nav-item-day" d))
2223                      (format out-stream "</div>"))
2224                    (format out-stream "</div>"))))
2225         (multiple-value-bind (posts total)
2226           (lw2-graphql-query (lw2-query-string :post :list
2227                                                (alist :view (if day "new" "top") :limit 51 :offset offset
2228                                                       :after (if (and year (not day)) (format nil "~A-~A-~A" (or year earliest-year) (or month 1) (or day 1)))
2229                                                       :before (if year (format nil "~A-~A-~A" (or year current-year) (or month 12)
2230                                                                                (or day (local-time:days-in-month (or month 12) (or year current-year))))))))
2231           (emit-page (out-stream :title "Archive" :current-uri "/archive" :content-class "archive-page"
2232                                  :top-nav #'archive-nav
2233                                  :pagination (pagination-nav-bars :items-per-page 50 :offset offset :total total :with-next (if total nil (> (length posts) 50))))
2234                      (write-index-items-to-html out-stream (firstn posts 50) :empty-message "No posts for the selected period.")))))))
2235
2236 (define-page view-about "/about" ()
2237   (emit-page (out-stream :title "About" :current-uri "/about" :content-class "about-page")
2238              (alexandria:with-input-from-file (in-stream "www/about.html" :element-type '(unsigned-byte 8))
2239                                               (alexandria:copy-stream in-stream out-stream))))
2240
2241 (define-page misc-pages (:regex "^/misc-pages/.+") ()
2242   (let ((pathname (hunchentoot:request-pathname)))
2243     (unless (probe-file pathname)
2244       (error 'lw2-not-found-error))
2245     (emit-page (out-stream :title "Misc page" :content-class "misc-page")
2246                (alexandria:with-input-from-file (in-stream pathname :element-type '(unsigned-byte 8))
2247                  (alexandria:copy-stream in-stream out-stream)))))
2248
2249 (define-page view-generated-script (:regex "^/generated/([^/]+)\\.js" (name :type string)) ()
2250   (when-let ((package (find-package (string-upcase name))))
2251     (setf (hunchentoot:header-out "Content-Type") "text/javascript")
2252     (let ((stream (make-flexi-stream (hunchentoot:send-headers) :external-format :utf-8)))
2253       (write-package-client-scripts package stream))))
2254
2255 (hunchentoot:define-easy-handler
2256     (view-proxy-asset
2257      :uri (lambda (r)
2258             (with-error-page
2259               (multiple-value-bind (match? strings) (ppcre:scan-to-strings "^/proxy-assets/([0-9A-Za-z]+)(-inverted)?$" (hunchentoot:script-name r) :sharedp t)
2260                 (when-let* ((base-filename (and match? (svref strings 0)))
2261                             (image-data (cache-get "cached-images" base-filename :value-type :json)))
2262                   (let ((inverted (svref strings 1)))
2263                     (alist-bind ((mime-type simple-string)) image-data
2264                       (setf (hunchentoot:header-out "X-Content-Type-Options") "nosniff"
2265                             (hunchentoot:header-out "Cache-Control") #.(format nil "public, max-age=~A, immutable" 600))
2266                       (hunchentoot:handle-static-file (concatenate 'string "www/proxy-assets/" base-filename (if inverted "-inverted" "")) mime-type)
2267                       t)))))))
2268     nil)