lw2.lisp

   1 (uiop:define-package #:lw2-viewer
   2   (:use #:cl #:sb-thread #:flexi-streams #:djula
   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)
   4   (:unintern
   5     #:define-regex-handler #:*fonts-stylesheet-uri* #:generate-fonts-link
   6     #:user-nav-bar #:*primary-nav* #:*secondary-nav* #:*nav-bars*
   7     #:begin-html #:end-html))
   8
   9 (in-package #:lw2-viewer)
  10
  11 (named-readtables:in-readtable html-reader)
  12
  13 (add-template-directory (asdf:system-relative-pathname "lw2-viewer" "templates/"))
  14
  15 (define-cache-database "auth-token-to-userid" "auth-token-to-username" "comment-markdown-source" "post-markdown-source")
  16
  17 (defvar *current-auth-token*)
  18 (defvar *current-userid*)
  19 (defvar *current-username*)
  20 (defvar *current-user-slug*)
  21
  22 (defvar *read-only-mode* nil)
  23 (defvar *read-only-default-message* "Due to a system outage, you cannot log in or post at this time.")
  24
  25 (defparameter *default-prefs* (alist :items-per-page 20 :default-sort "new"))
  26 (defvar *current-prefs* nil)
  27
  28 (defun logged-in-userid (&optional is-userid)
  29   (let ((current-userid *current-userid*))
  30     (if is-userid
  31         (string= current-userid is-userid)
  32         current-userid)))
  33
  34 (defun logged-in-username ()
  35   *current-username*)
  36
  37 (defun logged-in-user-slug ()
  38   *current-user-slug*)
  39
  40 (defun pretty-time (timestring &key format)
  41   (let ((time (local-time:parse-timestring timestring)))
  42   (values (local-time:format-timestring nil time :timezone local-time:+utc-zone+ :format (or format '(:day #\  :short-month #\  :year #\  :hour #\: (:min 2) #\  :timezone)))
  43           (* (local-time:timestamp-to-unix time) 1000))))
  44
  45 (defun pretty-number (number &optional object)
  46   (let ((str (coerce (format nil "~:D~@[<span> ~A~P</span>~]" number object number) '(vector character))))
  47     (if (eq (aref str 0) #\-)
  48       (setf (aref str 0) #\MINUS_SIGN))
  49     str))
  50
  51 (defun generate-post-auth-link (post &optional comment-id absolute need-auth)
  52   (if need-auth
  53       (concatenate 'string (generate-post-link post comment-id absolute) "?need-auth=y")
  54       (generate-post-link post comment-id absolute)))
  55
  56 (defun clean-lw-link (url)
  57   (when url
  58     (ppcre:regex-replace "([^/]*//[^/]*)lesserwrong\.com" url "\\1lesswrong.com")))
  59
  60 (defmacro alist-bind (bindings alist &body body)
  61   "Binds elements of ALIST so they can be used as if they were lexical variables.
  62
  63 Syntax: alist-bind (binding-entry*) alist forms*
  64 => result*
  65 binding-entry ::= (variable-name &optional type alist-key)
  66
  67 Each VARIABLE-NAME is bound to the corresponding datum in ALIST. Modifying these
  68 bindings with SETF will also update the ALIST.
  69 TYPE: type designator, not evaluated.
  70 ALIST-KEY: the alist key, as in the first argument to ASSOC. If it is not
  71 specified, the KEYWORD symbol with the same name as VARIABLE-NAME is used."
  72   (alexandria:once-only (alist)
  73     (let ((inner-bindings (loop for x in bindings collect
  74                                 (destructuring-bind (bind &optional type key) (if (consp x) x (list x))
  75                                   (list (gensym (string bind)) (gensym (string bind)) (gensym (string bind)) bind (or type t) (or key (intern (string bind) '#:keyword)))))))
  76       (macrolet ((inner-loop (&body body)
  77                    `(loop for (fn-gensym cons-gensym value-gensym bind type key) in inner-bindings collect
  78                           (progn fn-gensym cons-gensym value-gensym bind type key ,@body))))
  79         `(let* (,@(inner-loop `(,cons-gensym (assoc ,key ,alist)))
  80                 ,@(inner-loop `(,value-gensym (cdr ,cons-gensym))))
  81              (declare ,@(inner-loop `(type ,type ,value-gensym)))
  82              (flet (,@(inner-loop `(,fn-gensym () ,value-gensym))
  83                     ,@(inner-loop `((setf ,fn-gensym) (new) (setf (cdr ,cons-gensym) new ,value-gensym new))))
  84                (declare (inline ,@(inner-loop fn-gensym)))
  85                (symbol-macrolet ,(inner-loop `(,bind (,fn-gensym)))
  86                  ,@body)))))))
  87
  88 (defun votes-to-tooltip (votes)
  89   (if votes
  90       (format nil "~A vote~:*~P"
  91               (typecase votes (integer votes) (list (length votes))))
  92       ""))
  93
  94 (defun post-section-to-html (out-stream post &key skip-section)
  95   (alist-bind ((user-id string)
  96                (frontpage-date (or null string))
  97                (curated-date (or null string))
  98                (meta boolean)
  99                (af boolean)
 100                (draft boolean))
 101     post
 102     (format out-stream "~1{<a class=\"post-section ~A\" title=\"~A\"~1@{ href=\"~A\"~}></a>~}"
 103             (cond (af (if (eq skip-section :alignment-forum) nil (list "alignment-forum" "View Alignment Forum posts" "/index?view=alignment-forum")))
 104                   ; show alignment forum even if skip-section is t
 105                   ((eq skip-section t) nil)
 106                   (draft nil)
 107                   (curated-date (if (eq skip-section :featured) nil (list "featured" "View Featured posts" "/index?view=featured")))
 108                   (frontpage-date (if (eq skip-section :frontpage) nil (list "frontpage" "View Frontpage posts" "/")))
 109                   (meta (if (eq skip-section :meta) nil (list "meta" "View Meta posts" "/index?view=meta")))
 110                   (t (if (eq skip-section :personal) nil (list "personal" (format nil "View posts by ~A" (get-username user-id)) (format nil "/users/~A?show=posts" (get-user-slug user-id)))))))))
 111
 112 (defun post-headline-to-html (out-stream post &key skip-section need-auth)
 113   (alist-bind ((post-id string :--id)
 114                (title string)
 115                (user-id string)
 116                (url (or null string))
 117                (posted-at string)
 118                (base-score fixnum)
 119                (comment-count (or null fixnum))
 120                (page-url (or null string))
 121                (word-count (or null fixnum))
 122                (frontpage-date (or null string))
 123                (curated-date (or null string))
 124                (meta boolean)
 125                (af boolean)
 126                (question boolean)
 127                (vote-count (or null fixnum))
 128                (draft boolean))
 129     post
 130     (multiple-value-bind (pretty-time js-time) (pretty-time posted-at)
 131       (format out-stream "<h1 class=\"listing~:[~; link-post-listing~]~:[~; question-post-listing~]~:[~; own-post-listing~]\">~@[<a href=\"~A\">&#xf0c1;</a>~]<a href=\"~A\">~:[~;<span class=\"post-type-prefix\">[Question] </span>~]~A</a>~@[<a class=\"edit-post-link button\" href=\"/edit-post?post-id=~A\"></a>~]</h1>"
 132               url
 133               question
 134               (logged-in-userid user-id)
 135               (if url (encode-entities (convert-any-link (string-trim " " url))))
 136               (generate-post-auth-link post nil nil need-auth)
 137               question
 138               (clean-text-to-html title)
 139               (if (logged-in-userid user-id) post-id))
 140       (format out-stream "<div class=\"post-meta\"><a class=\"author~:[~; own-user-author~]\" href=\"/users/~A\" data-userid=\"~A\">~A</a> <div class=\"date\" data-js-date=\"~A\">~A</div><div class=\"karma\"><span class=\"karma-value\" title=\"~A\">~A</span></div><a class=\"comment-count\" href=\"~A#comments\">~A</a>~:[~*~;~:*<span class=\"read-time\" title=\"~:D word~:P\">~:D<span> min read</span></span>~]~:[~*~;~:*<a class=\"lw2-link\" href=\"~A\">~A<span> link</span></a>~]"
 141               (logged-in-userid user-id)
 142               (encode-entities (get-user-slug user-id))
 143               (encode-entities user-id)
 144               (encode-entities (get-username user-id))
 145               js-time
 146               pretty-time
 147               (votes-to-tooltip vote-count)
 148               (pretty-number base-score "point")
 149               (generate-post-link post)
 150               (pretty-number (or comment-count 0) "comment")
 151               word-count
 152               (and word-count (max 1 (round word-count 300)))
 153               (clean-lw-link page-url)
 154               (main-site-abbreviation *current-site*)))
 155     (post-section-to-html out-stream post :skip-section skip-section)
 156     (if url (format out-stream "<div class=\"link-post-domain\">(~A)</div>" (encode-entities (puri:uri-host (puri:parse-uri (string-trim " " url))))))
 157     (format out-stream "</div>")))
 158
 159 (defun post-body-to-html (out-stream post)
 160   (alist-bind ((post-id string :--id)
 161                (title string)
 162                (user-id string)
 163                (url (or null string))
 164                (posted-at string)
 165                (base-score fixnum)
 166                (comment-count (or null fixnum))
 167                (page-url (or null string))
 168                (frontpage-date (or null string))
 169                (curated-date (or null string))
 170                (meta boolean)
 171                (draft boolean)
 172                (af boolean)
 173                (question boolean)
 174                (vote-count (or null fixnum))
 175                (html-body (or null string)))
 176     post
 177     (multiple-value-bind (pretty-time js-time) (pretty-time posted-at)
 178       (format out-stream "<div class=\"post~:[~; link-post~]~:[~; question-post~]\"><h1 class=\"post-title\">~:*~:[~;<span class=\"post-type-prefix\">[Question] </span>~]~A</h1><div class=\"post-meta\"><a class=\"author~:[~; own-user-author~]\" href=\"/users/~A\" data-userid=\"~A\">~A</a> <div class=\"date\" data-js-date=\"~A\">~A</div><div class=\"karma\" data-post-id=\"~A\"><span class=\"karma-value\" title=\"~A\">~A</span></div><a class=\"comment-count\" href=\"#comments\">~A</a>~:[~*~;~:*<a class=\"lw2-link\" href=\"~A\">~A<span> link</span></a>~]"
 179               url
 180               question
 181               (clean-text-to-html title :hyphenation nil)
 182               (logged-in-userid user-id)
 183               (encode-entities (get-user-slug user-id))
 184               (encode-entities user-id)
 185               (encode-entities (get-username user-id))
 186               js-time
 187               pretty-time
 188               post-id
 189               (votes-to-tooltip vote-count)
 190               (pretty-number base-score "point")
 191               (pretty-number (or comment-count 0) "comment")
 192               (clean-lw-link page-url)
 193               (main-site-abbreviation *current-site*)))
 194     (post-section-to-html out-stream post)
 195     (format out-stream "</div><div class=\"post-body\">")
 196     (if url (format out-stream "<p><a href=\"~A\" class=\"link-post-link\">Link post</a></p>" (encode-entities (convert-any-link (string-trim " " url)))))
 197     (write-sequence (clean-html* (or html-body "") :with-toc t :post-id post-id) out-stream)
 198     (format out-stream "</div></div>")))
 199
 200 (defparameter *comment-individual-link* nil)
 201
 202 (defun comment-to-html (out-stream comment &key with-post-title)
 203   (if (or (cdr (assoc :deleted comment)) (cdr (assoc :deleted-public comment)))
 204       (format out-stream "<div class=\"comment deleted-comment\"><div class=\"comment-meta\"><span class=\"deleted-meta\">[ ]</span></div><div class=\"comment-body\">[deleted]</div></div>")
 205       (alist-bind ((comment-id string :--id)
 206                    (user-id string)
 207                    (posted-at string)
 208                    (highlight-new boolean)
 209                    (post-id string)
 210                    (base-score fixnum)
 211                    (page-url (or null string))
 212                    (parent-comment list)
 213                    (parent-comment-id (or null string))
 214                    (child-count (or null fixnum))
 215                    (children list)
 216                    (vote-count (or null fixnum))
 217                    (retracted boolean)
 218                    (html-body string))
 219                   comment
 220                   (multiple-value-bind (pretty-time js-time) (pretty-time posted-at)
 221                     <div class=("comment~{ ~A~}"
 222                                        (let ((l nil))
 223                                          (if (and (logged-in-userid user-id)
 224                                                   (< (* 1000 (local-time:timestamp-to-unix (local-time:now))) (+ js-time 15000)))
 225                                              (push "just-posted-comment" l))
 226                                          (if highlight-new (push "comment-item-highlight" l))
 227                                          (if retracted (push "retracted" l))
 228                                          l))>
 229                       <div class="comment-meta">
 230                         <a class=("author~:[~; own-user-author~]" (logged-in-userid user-id))
 231                            href=("/users/~A" (encode-entities (get-user-slug user-id)))
 232                            data-userid=user-id>
 233                           (get-username user-id)
 234                         </a>
 235                         <a class="date" href=(generate-post-link post-id comment-id) data-js-date=js-time> (safe pretty-time) </a>
 236                         <div class="karma">
 237                           <span class="karma-value" title=(votes-to-tooltip vote-count)> (safe (pretty-number base-score "point")) </span>
 238                         </div>
 239                         <a class="permalink" href=("~A/comment/~A" (generate-post-link post-id) comment-id) title="Permalink"></a>
 240                         (with-html-stream-output
 241                           (when page-url
 242                             <a class="lw2-link" href=(clean-lw-link page-url) title=(main-site-abbreviation *current-site*)></a>)
 243                           (if with-post-title
 244                               <div class="comment-post-title">
 245                                 (with-html-stream-output
 246                                     (when parent-comment
 247                                       (alist-bind ((user-id string)
 248                                                    (post-id string)
 249                                                    (parent-id string :--id))
 250                                                   parent-comment
 251                                         <span class="comment-in-reply-to">in reply to:
 252                                           <a href=("/users/~A" (get-user-slug user-id))
 253                                              class=("inline-author~:[~; own-user-author~]" (logged-in-userid user-id))
 254                                              data-userid=(progn user-id)>
 255                                              (get-username user-id)</a>'s
 256                                           <a href=(generate-post-link post-id parent-id)>comment</a>
 257                                           (progn " ")
 258                                         </span>)))
 259                                   <span class="comment-post-title2">on: <a href=(generate-post-link post-id)>(safe (clean-text-to-html (get-post-title post-id)))</a></span>
 260                                 </div>
 261                             (when parent-comment-id
 262                               (if *comment-individual-link*
 263                                   <a class="comment-parent-link" href=(progn parent-comment-id) title="Parent"></a>
 264                                   <a class="comment-parent-link" href=("#comment-~A" parent-comment-id)>Parent</a>)))
 265                           (when children
 266                             <div class="comment-child-links">
 267                               Replies:
 268                               (with-html-stream-output
 269                                 (dolist (child children)
 270                                   (alist-bind ((comment-id string)
 271                                                (user-id string))
 272                                               child
 273                                     <a href=("#comment-~A" comment-id)>(">~A" (get-username user-id))</a>)))
 274                             </div>)
 275                           <div class="comment-minimize-button"
 276                                data-child-count=(progn child-count)>
 277                           </div>)
 278                         </div>
 279                         <div class="comment-body" (safe ("~@[ data-markdown-source=\"~A\"~]"
 280                                                          (if (logged-in-userid user-id)
 281                                                              (encode-entities
 282                                                               (or (cache-get "comment-markdown-source" comment-id)
 283                                                                   html-body)))))>
 284                           (with-html-stream-output (write-sequence (clean-html* html-body) out-stream))
 285                         </div>
 286                       </div>))))
 287
 288 (defun postprocess-conversation-title (title)
 289   (if (or (null title) (string= title ""))
 290       "[Untitled conversation]"
 291       title))
 292
 293 (defun conversation-message-to-html (out-stream message)
 294   (alist-bind ((user-id string)
 295                (created-at string)
 296                (highlight-new boolean)
 297                (conversation list)
 298                (content list)
 299                (html-body (or string null)))
 300     message
 301     (multiple-value-bind (pretty-time js-time) (pretty-time created-at)
 302       (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</span><div class=\"comment-post-title\">Private message in: <a href=\"/conversation?id=~A\">~A</a></div></div><div class=\"comment-body\">"
 303               (if highlight-new " comment-item-highlight" "")
 304               (encode-entities (get-user-slug user-id))
 305               (encode-entities (get-username user-id))
 306               js-time
 307               pretty-time
 308               (encode-entities (cdr (assoc :--id conversation)))
 309               (encode-entities (postprocess-conversation-title (cdr (assoc :title conversation))))))
 310     (if html-body
 311         (write-sequence (clean-html* html-body) out-stream)
 312         (format out-stream "~{<p>~A</p>~}" (loop for block in (cdr (assoc :blocks content)) collect (encode-entities (cdr (assoc :text block))))))
 313     (format out-stream "</div></div>")))
 314
 315 (defun conversation-index-to-html (out-stream conversation)
 316   (alist-bind ((conversation-id string :--id)
 317                (title (or null string))
 318                (created-at (or null string))
 319                (participants list)
 320                (messages-total fixnum))
 321     conversation
 322     (multiple-value-bind (pretty-time js-time) (if created-at (pretty-time created-at) (values "[Error]" 0))
 323       (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</div></div>"
 324               (encode-entities conversation-id)
 325               (encode-entities (postprocess-conversation-title title))
 326               (loop for p in participants
 327                     collect (list (encode-entities (cdr (assoc :slug p))) (encode-entities (cdr (assoc :display-name p)))))
 328               (pretty-number messages-total "message")
 329               js-time
 330               pretty-time))))
 331
 332 (defun error-to-html (out-stream condition)
 333   (format out-stream "<div class=\"gw-error\"><h1>Error</h1><p>~A</p></div>"
 334           (encode-entities (princ-to-string condition))))
 335
 336 (defmacro with-error-html-block ((out-stream) &body body)
 337   "If an error occurs within BODY, write an HTML representation of the
 338 signaled condition to OUT-STREAM."
 339   `(handler-case
 340      (progn ,@body)
 341      (serious-condition (c) (error-to-html ,out-stream c))))
 342
 343 (defun make-comment-parent-hash (comments)
 344   (let ((existing-comment-hash (make-hash-table :test 'equal))
 345         (hash (make-hash-table :test 'equal)))
 346     (dolist (c comments)
 347       (alexandria:if-let (id (cdr (assoc :--id c)))
 348                          (setf (gethash id existing-comment-hash) t)))
 349     (dolist (c comments)
 350       (let* ((parent-id (cdr (assoc :parent-comment-id c)))
 351              (old (gethash parent-id hash)))
 352         (setf (gethash parent-id hash) (cons c old))
 353         (when (and parent-id (not (gethash parent-id existing-comment-hash)))
 354           (let ((placeholder (alist :--id parent-id :parent-comment-id nil :deleted t)))
 355             (setf (gethash parent-id existing-comment-hash) t
 356                   (gethash nil hash) (cons placeholder (gethash nil hash)))))))
 357     (maphash (lambda (k old)
 358                (setf (gethash k hash) (nreverse old)))
 359              hash)
 360     (labels
 361       ((count-children (parent)
 362         (let ((children (gethash (cdr (assoc :--id parent)) hash)))
 363           (+ (length children) (apply #'+ (map 'list #'count-children children)))))
 364        (add-child-counts (comment-list)
 365         (loop for c in comment-list
 366               as id = (cdr (assoc :--id c))
 367               do (setf (gethash id hash) (add-child-counts (gethash id hash)))
 368               collecting (cons (cons :child-count (count-children c)) c))))
 369       (setf (gethash nil hash) (add-child-counts (gethash nil hash))))
 370     hash))
 371
 372 (defun comment-thread-to-html (out-stream emit-comment-item-fn)
 373   (format out-stream "<ul class=\"comment-thread\">")
 374   (funcall emit-comment-item-fn)
 375   (format out-stream "</ul>"))
 376
 377 (defun comment-item-to-html (out-stream comment &key extra-html-fn)
 378   (with-error-html-block (out-stream)
 379     (let ((c-id (cdr (assoc :--id comment))))
 380       (format out-stream "<li id=\"comment-~A\" class=\"comment-item\">" c-id)
 381       (unwind-protect
 382         (comment-to-html out-stream comment)
 383         (if extra-html-fn (funcall extra-html-fn c-id))
 384         (format out-stream "</li>")))))
 385
 386 (defun comment-tree-to-html (out-stream comment-hash &optional (target nil) (level 0))
 387   (let ((comments (gethash target comment-hash)))
 388     (when comments
 389       (comment-thread-to-html out-stream
 390         (lambda ()
 391           (loop for c in comments do
 392                 (comment-item-to-html out-stream c
 393                   :extra-html-fn (lambda (c-id)
 394                                    (if (and (= level 10) (gethash c-id comment-hash))
 395                                        (format out-stream "<input type=\"checkbox\" id=\"expand-~A\"><label for=\"expand-~:*~A\" data-child-count=\"~A comment~:P\">Expand this thread</label>"
 396                                                c-id
 397                                                (cdr (assoc :child-count c))))
 398                                    (comment-tree-to-html out-stream comment-hash c-id (1+ level))))))))))
 399
 400 (defun comment-chrono-to-html (out-stream comments)
 401   (let ((comment-hash (make-comment-parent-hash comments))
 402         (comments-sorted (sort comments #'local-time:timestamp< :key (lambda (c) (local-time:parse-timestring (cdr (assoc :posted-at c)))))))
 403     (comment-thread-to-html out-stream
 404       (lambda ()
 405         (loop for c in comments-sorted do
 406               (let* ((c-id (cdr (assoc :--id c)))
 407                      (new-c (acons :children (gethash c-id comment-hash) c)))
 408                 (comment-item-to-html out-stream new-c)))))))
 409
 410 (defun comment-post-interleave (list &key limit offset (sort-by :date))
 411   (multiple-value-bind (sort-fn sort-key)
 412     (ecase sort-by
 413       (:date (values #'local-time:timestamp> (lambda (x) (local-time:parse-timestring (cdr (assoc :posted-at x))))))
 414       (:score (values #'> (lambda (x) (cdr (assoc :base-score x))))))
 415     (let ((sorted (sort list sort-fn :key sort-key)))
 416       (loop for end = (if (or limit offset) (+ (or limit 0) (or offset 0)))
 417             for x in sorted
 418             for count from 0
 419             until (and end (>= count end))
 420             when (or (not offset) (>= count offset))
 421             collect x))))
 422
 423 (defun write-index-items-to-html (out-stream items &key need-auth (empty-message "No entries.") skip-section)
 424   (if items
 425       (dolist (x items)
 426         (with-error-html-block (out-stream)
 427           (cond
 428             ((typep x 'condition)
 429              (error-to-html out-stream x))
 430             ((assoc :message x)
 431              (format out-stream "<p>~A</p>" (cdr (assoc :message x))))
 432             ((string= (cdr (assoc :----typename x)) "Message")
 433              (format out-stream "<ul class=\"comment-thread\"><li class=\"comment-item\">")
 434              (unwind-protect
 435                (conversation-message-to-html out-stream x)
 436                (format out-stream "</li></ul>")))
 437             ((string= (cdr (assoc :----typename x)) "Conversation")
 438              (conversation-index-to-html out-stream x))
 439             ((assoc :comment-count x)
 440              (post-headline-to-html out-stream x :need-auth need-auth :skip-section skip-section))
 441             (t
 442              (format out-stream "<ul class=\"comment-thread\"><li class=\"comment-item\" id=\"comment-~A\">" (cdr (assoc :--id x)))
 443              (unwind-protect
 444                (comment-to-html out-stream x :with-post-title t)
 445                (format out-stream "</li></ul>"))))))
 446       (format out-stream "<div class=\"listing-message\">~A</div>" empty-message)))
 447
 448 (defun write-index-items-to-rss (out-stream items &key title need-auth)
 449   (let ((full-title (format nil "~@[~A - ~]~A" title (site-title *current-site*))))
 450     (xml-emitter:with-rss2 (out-stream :encoding "UTF-8")
 451       (xml-emitter:rss-channel-header full-title (site-uri *current-site*) :description full-title)
 452       (labels ((emit-item (item &key title link (guid (cdr (assoc :--id item))) (author (get-username (cdr (assoc :user-id item))))
 453                                 (date (pretty-time (cdr (assoc :posted-at item)) :format local-time:+rfc-1123-format+)) body)
 454                           (xml-emitter:rss-item
 455                             title
 456                             :link link
 457                             :author author
 458                             :pubDate date
 459                             :guid guid
 460                             :description body)))
 461         (dolist (item items)
 462           (if (assoc :comment-count item)
 463             (let ((author (get-username (cdr (assoc :user-id item)))))
 464               (emit-item item
 465                          :title (clean-text (format nil "~A by ~A" (cdr (assoc :title item)) author))
 466                          :author author
 467                          :link (generate-post-auth-link item nil t need-auth)
 468                          :body (clean-html (or (cdr (assoc :html-body (get-post-body (cdr (assoc :--id item)) :revalidate nil))) "") :post-id (cdr (assoc :--id item)))))
 469             (emit-item item
 470                        :title (format nil "Comment by ~A on ~A" (get-username (cdr (assoc :user-id item))) (get-post-title (cdr (assoc :post-id item))))
 471                        :link (generate-post-link (cdr (assoc :post-id item)) (cdr (assoc :--id item)) t)
 472                        :body (clean-html (cdr (assoc :html-body item))))))))))
 473
 474 (defparameter *fonts-stylesheet-uris*
 475   '("https://fonts.greaterwrong.com/?fonts=InconsolataGW,CharterGW,ConcourseGW,Whitney,MundoSans,SourceSansPro,Raleway,ProximaNova,TiredOfCourier,AnonymousPro,InputSans,InputSansNarrow,InputSansCondensed,GaramondPremierPro,TriplicateCode,TradeGothic,NewsGothicBT,Caecilia,SourceSerifPro,SourceCodePro"
 476     "https://fonts.greaterwrong.com/?fonts=BitmapFonts,FontAwesomeGW&base64encode=1"))
 477 ;(defparameter *fonts-stylesheet-uris* '("https://fonts.greaterwrong.com/?fonts=*"))
 478
 479 (defvar *fonts-redirect-data* nil)
 480 (sb-ext:defglobal *fonts-redirect-lock* (make-mutex))
 481 (sb-ext:defglobal *fonts-redirect-thread* nil)
 482
 483 (defun generate-fonts-links ()
 484   (let ((current-time (get-unix-time)))
 485     (labels ((get-redirects (uri-list)
 486                (loop for request-uri in uri-list collect
 487                      (multiple-value-bind (body status headers uri)
 488                        (drakma:http-request request-uri :method :head :close t :redirect nil :additional-headers (alist :referer (site-uri (first *sites*)) :accept "text/css,*/*;q=0.1"))
 489                        (declare (ignore body uri))
 490                        (let ((location (cdr (assoc :location headers))))
 491                          (if (and (typep status 'integer) (< 300 status 400) location)
 492                              location
 493                              nil)))))
 494              (update-redirects ()
 495                (handler-case
 496                  (let* ((new-redirects (get-redirects *fonts-stylesheet-uris*))
 497                         (new-redirects (loop for new-redirect in new-redirects
 498                                              for original-uri in *fonts-stylesheet-uris*
 499                                              collect (if new-redirect (quri:render-uri (quri:merge-uris (quri:uri new-redirect) (quri:uri original-uri))) original-uri))))
 500                    (with-mutex (*fonts-redirect-lock*) (setf *fonts-redirect-data* (list *fonts-stylesheet-uris* new-redirects current-time)
 501                                                              *fonts-redirect-thread* nil))
 502                    new-redirects)
 503                  (serious-condition () *fonts-stylesheet-uris*)))
 504              (ensure-update-thread ()
 505                (with-mutex (*fonts-redirect-lock*)
 506                  (or *fonts-redirect-thread*
 507                      (setf *fonts-redirect-thread* (make-thread #'update-redirects :name "fonts redirect update"))))))
 508       (destructuring-bind (&optional base-uris redirect-uris timestamp) (with-mutex (*fonts-redirect-lock*) *fonts-redirect-data*)
 509         (if (and (eq base-uris *fonts-stylesheet-uris*) timestamp)
 510           (progn
 511             (if (>= current-time (+ timestamp 60))
 512                 (ensure-update-thread))
 513             (or redirect-uris *fonts-stylesheet-uris*))
 514           (update-redirects))))))
 515
 516 (defparameter *html-head*
 517   (format nil
 518 "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">
 519 <meta name=\"HandheldFriendly\" content=\"True\" />"))
 520
 521 (defparameter *extra-external-scripts* "")
 522 (defparameter *extra-inline-scripts* "")
 523
 524 (defun generate-versioned-link (file)
 525   (format nil "~A?v=~A" file (sb-posix:stat-mtime (sb-posix:stat (format nil "www~A" file)))))
 526
 527 (defun search-bar-to-html (out-stream)
 528   (declare (special *current-search-query*))
 529   (let ((query (and (boundp '*current-search-query*) (hunchentoot:escape-for-html *current-search-query*))))
 530     (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*))))
 531
 532 (defun inbox-to-html (out-stream user-slug &optional new-messages)
 533   (let* ((target-uri (format nil "/users/~A?show=inbox" user-slug))
 534          (as-link (string= (hunchentoot:request-uri*) target-uri)))
 535     (multiple-value-bind (nm-class nm-text)
 536       (if new-messages (values "new-messages" "New messages") (values "no-messages" "Inbox"))
 537       (format out-stream "<~:[a href=\"~A\"~;span~*~] id=\"inbox-indicator\" class=\"~A\" accesskey=\"o\" title=\"~A~:[ [o]~;~]\">~A</a>"
 538               as-link target-uri nm-class nm-text as-link nm-text))))
 539
 540 (defmethod site-nav-bars ((site site))
 541   '((:secondary-bar (("archive" "/archive" "Archive" :accesskey "r")
 542                      ("about" "/about" "About" :accesskey "t")
 543                      user-nav-item))
 544     (:primary-bar (("home" "/" "Home" :description "Latest frontpage posts" :accesskey "h")
 545                    ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description "Latest comments" :accesskey "c")))))
 546
 547 (defmethod site-nav-bars ((site lesswrong-viewer-site))
 548   '((:secondary-bar (("archive" "/archive" "Archive" :accesskey "r")
 549                      ("about" "/about" "About" :accesskey "t")
 550                      ("search" "/search" "Search" :html search-bar-to-html)
 551                      user-nav-item))
 552     (:primary-bar (("home" "/" "Home" :description "Latest frontpage posts" :accesskey "h")
 553                    ("featured" "/index?view=featured" "Featured" :description "Latest featured posts" :accesskey "f")
 554                    ("all" "/index?view=all" "All" :description "Latest posts from all sections" :accesskey "a")
 555                    ("meta" "/index?view=meta" "Meta" :description "Latest meta posts" :accesskey "m")
 556                    ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description "Latest comments" :accesskey "c")))))
 557
 558 (defmethod site-nav-bars ((site ea-forum-viewer-site))
 559   '((:secondary-bar (("archive" "/archive" "Archive" :accesskey "r")
 560                      ("about" "/about" "About" :accesskey "t")
 561                      ("search" "/search" "Search" :html search-bar-to-html)
 562                      user-nav-item))
 563     (:primary-bar (("home" "/" "Home" :description "Latest frontpage posts" :accesskey "h")
 564                    ("all" "/index?view=all" "All" :description "Latest posts from all sections" :accesskey "a")
 565                    ("meta" "/index?view=community" "Community" :description "Latest community posts" :accesskey "m")
 566                    ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description "Latest comments" :accesskey "c")))))
 567
 568 (defun prepare-nav-bar (nav-bar current-uri)
 569   (list (first nav-bar)
 570         (map 'list (lambda (item) (if (listp item) item (funcall item current-uri)))
 571              (second nav-bar))))
 572
 573 (defun nav-item-active (item current-uri)
 574   (when item
 575     (destructuring-bind (id uri name &key description html accesskey nofollow trailing-html override-uri) item
 576       (declare (ignore id name description html accesskey nofollow trailing-html))
 577       (string= (or override-uri uri) current-uri))))
 578
 579 (defun nav-bar-active (nav-bar current-uri)
 580   (some (lambda (x) (nav-item-active x current-uri)) (second nav-bar)))
 581
 582 (defun nav-bar-inner (out-stream items &optional current-uri)
 583   (maplist (lambda (items)
 584              (let ((item (first items)))
 585                (destructuring-bind (id uri name &key description html accesskey nofollow trailing-html override-uri) item
 586                  (declare (ignore override-uri))
 587                  (let* ((item-active (nav-item-active item current-uri))
 588                         (nav-class (format nil "nav-item ~:[nav-inactive~;nav-current~]~:[~; nav-item-last-before-current~]"
 589                                            item-active (and (not item-active) (nav-item-active (cadr items) current-uri)))))
 590                      (format out-stream "<span id=\"nav-item-~A\" class=\"~A\" ~@[title=\"~A\"~]>"
 591                              id nav-class description)
 592                      (if html
 593                          (funcall html out-stream)
 594                          (link-if-not out-stream item-active uri "nav-inner" name :accesskey accesskey :nofollow nofollow))
 595                      (if trailing-html
 596                          (funcall trailing-html out-stream))
 597                      (format out-stream "</span>")))))
 598            items))
 599
 600 (defun nav-bar-outer (out-stream class nav-bar &optional current-uri)
 601   (format out-stream "<div id=\"~A\" class=\"nav-bar~@[ ~A~]\">" (string-downcase (first nav-bar)) class)
 602   (nav-bar-inner out-stream (second nav-bar) current-uri)
 603   (format out-stream "</div>"))
 604
 605 (defun nav-bar-to-html (out-stream &optional current-uri)
 606   (let* ((nav-bars (map 'list (lambda (x) (prepare-nav-bar x current-uri)) (site-nav-bars *current-site*)))
 607          (active-bar (or (find-if (lambda (x) (nav-bar-active x current-uri)) nav-bars) (car (last nav-bars))))
 608          (inactive-bars (remove active-bar nav-bars)))
 609     (dolist (bar inactive-bars)
 610       (nav-bar-outer out-stream "inactive-bar" bar current-uri))
 611     (nav-bar-outer out-stream "active-bar" active-bar current-uri)))
 612
 613 (defun user-nav-item (&optional current-uri)
 614   (if *read-only-mode*
 615       `("login" "/login" "Read Only Mode" :html ,(lambda () (format nil "<span class=\"nav-inner\" title=\"~A\">[Read Only Mode]</span>"
 616                                                                     (typecase *read-only-mode*
 617                                                                       (string *read-only-mode*)
 618                                                                       (t *read-only-default-message*)))))
 619       (alexandria:if-let (username (logged-in-username))
 620           (let ((user-slug (encode-entities (logged-in-user-slug))))
 621             `("login" ,(format nil "/users/~A" user-slug) ,(plump:encode-entities username) :description "User page" :accesskey "u"
 622               :trailing-html ,(lambda (out-stream) (inbox-to-html out-stream user-slug))))
 623           `("login" ,(format nil "/login?return=~A" (url-rewrite:url-encode current-uri)) "Log In" :accesskey "u" :nofollow t :override-uri "/login"))))
 624
 625 (defun sublevel-nav-to-html (out-stream options current &key default (base-uri (hunchentoot:request-uri*)) (param-name "show") (remove-params '("offset")) extra-class)
 626   (declare (type (or null string) extra-class))
 627   (format out-stream "<div class=\"sublevel-nav~@[ ~A~]\">" extra-class)
 628   (loop for item in options
 629         do (multiple-value-bind (param-value text) (if (atom item)
 630                                                        (values (string-downcase item) (string-capitalize item))
 631                                                        (values-list item))
 632              (let* ((selected (string-equal current param-value))
 633                     (class (if selected "sublevel-item selected" "sublevel-item")))
 634                (link-if-not out-stream selected (apply #'replace-query-params base-uri param-name (unless (string-equal param-value default) param-value)
 635                                                        (loop for x in remove-params nconc (list x nil)))
 636                             class text))))
 637   (format out-stream "</div>"))
 638
 639 (defun make-csrf-token (&optional (session-token (hunchentoot:cookie-in "session-token")) (nonce (ironclad:make-random-salt)))
 640   (if (typep session-token 'string) (setf session-token (base64:base64-string-to-usb8-array session-token)))
 641   (let ((csrf-token (concatenate '(vector (unsigned-byte 8)) nonce (ironclad:digest-sequence :sha256 (concatenate '(vector (unsigned-byte 8)) nonce session-token)))))
 642     (values (base64:usb8-array-to-base64-string csrf-token) csrf-token)))
 643
 644 (defun check-csrf-token (csrf-token &optional (session-token (hunchentoot:cookie-in "session-token")))
 645   (let* ((session-token (base64:base64-string-to-usb8-array session-token))
 646          (csrf-token (base64:base64-string-to-usb8-array csrf-token))
 647          (correct-token (nth-value 1 (make-csrf-token session-token (subseq csrf-token 0 16)))))
 648     (assert (ironclad:constant-time-equal csrf-token correct-token) nil "CSRF check failed.")
 649     t))
 650
 651 (defun generate-css-link ()
 652   (labels ((gen-inner (theme os)
 653              (generate-versioned-link (format nil "/style~@[-~A~].~A.css" (if (and theme (> (length theme) 0)) theme) os))))
 654     (let* ((ua (hunchentoot:header-in* :user-agent))
 655            (theme (hunchentoot:cookie-in "theme"))
 656            (os (cond ((search "Windows" ua) "windows")
 657                      ((search "Mac OS" ua) "mac")
 658                      (t "linux"))))
 659       (handler-case (gen-inner theme os)
 660         (serious-condition () (gen-inner nil os))))))
 661
 662 (defun html-body (out-stream fn &key title description current-uri content-class robots)
 663   (let* ((session-token (hunchentoot:cookie-in "session-token"))
 664          (csrf-token (and session-token (make-csrf-token session-token))))
 665     (format out-stream "<!DOCTYPE html><html lang=\"en-US\"><head>")
 666     (format out-stream "<script>window.GW = { }; loggedInUserId=\"~A\"; loggedInUserDisplayName=\"~A\"; loggedInUserSlug=\"~A\"; ~@[GW.csrfToken=\"~A\"; ~]~A</script>~A"
 667             (or (logged-in-userid) "")
 668             (or (logged-in-username) "")
 669             (or (logged-in-user-slug) "")
 670             csrf-token
 671             (load-time-value (with-open-file (s "www/head.js") (uiop:slurp-stream-string s)) t)
 672             *extra-inline-scripts*)
 673     (format out-stream "~A<link rel=\"stylesheet\" href=\"~A\">~{<link rel=\"stylesheet\" href=\"~A\">~}<link rel=\"shortcut icon\" href=\"~A\">"
 674             *html-head*
 675             (generate-css-link)
 676             (generate-fonts-links)
 677             (generate-versioned-link "/favicon.ico"))
 678     (format out-stream "<script src=\"~A\" async></script>~A"
 679             (generate-versioned-link "/script.js")
 680             *extra-external-scripts*)
 681     (format out-stream "<title>~@[~A - ~]~A</title>~@[<meta name=\"description\" content=\"~A\">~]~@[<meta name=\"robots\" content=\"~A\">~]"
 682             (if title (encode-entities title))
 683             (site-title *current-site*)
 684             description
 685             robots)
 686     (format out-stream "</head>"))
 687   (unwind-protect
 688     (progn
 689       (format out-stream "<body><div id=\"content\"~@[ class=\"~A\"~]>"
 690               content-class)
 691       (nav-bar-to-html out-stream (or current-uri (replace-query-params (hunchentoot:request-uri*) "offset" nil "sort" nil)))
 692       (force-output out-stream)
 693       (funcall fn))
 694     (format out-stream "</div></body></html>")))
 695
 696 (defun replace-query-params (uri &rest params)
 697   (let* ((quri (quri:uri uri))
 698          (old-params (quri:uri-query-params quri))
 699          (new-params (loop with out = old-params
 700                            for (param value) on params by #'cddr
 701                            do (if value
 702                                   (alexandria:if-let (old-cons (assoc param out :test #'equal))
 703                                                      (setf (cdr old-cons) value)
 704                                                      (setf out (nconc out (list (cons param value)))))
 705                                   (setf out (remove-if (lambda (x) (equal (car x) param)) out)))
 706                            finally (return out))))
 707     (if new-params
 708       (setf (quri:uri-query-params quri) new-params)
 709       (setf (quri:uri-query quri) nil))
 710     (quri:render-uri quri)))
 711
 712 (defun pagination-nav-bars (&key offset total with-next (items-per-page (user-pref :items-per-page)))
 713   (lambda (out-stream fn)
 714     (labels ((pages-to-end (n) (< (+ offset (* items-per-page n)) total)))
 715       (let* ((with-next (if total (pages-to-end 1) with-next))
 716              (next (if (and offset with-next) (+ offset items-per-page)))
 717              (prev (if (and offset (>= offset items-per-page)) (- offset items-per-page)))
 718              (request-uri (hunchentoot:request-uri*))
 719              (first-uri (if (and prev (> prev 0)) (replace-query-params request-uri "offset" nil)))
 720              (prev-uri (if prev (replace-query-params request-uri "offset" (if (= prev 0) nil prev))))
 721              (next-uri (if next (replace-query-params request-uri "offset" next)))
 722              (last-uri (if (and total offset (pages-to-end 2))
 723                            (replace-query-params request-uri "offset" (- total (mod (- total 1) items-per-page) 1)))))
 724         (if (or next prev last-uri)
 725           (labels ((write-item (uri class title accesskey)
 726                      (format out-stream "<a href=\"~A\" class=\"button nav-item-~A~:[ disabled~;~]\" title=\"~A [~A]\" accesskey=\"~A\"></a>"
 727                              (or uri "#") class uri title accesskey accesskey)))
 728             (format out-stream "<div id='top-nav-bar'>")
 729             (write-item first-uri "first" "First page" "\\")
 730             (write-item prev-uri "prev" "Previous page" "[")
 731             (format out-stream "<span class='page-number'><span class='page-number-label'>Page</span> ~A</span>" (+ 1 (/ (or offset 0) items-per-page)))
 732             (write-item next-uri "next" "Next page" "]")
 733             (write-item last-uri "last" "Last page" "/")
 734             (format out-stream "</div>")))
 735         (funcall fn)
 736         (nav-bar-outer out-stream nil `(:bottom-bar
 737                                          (,@(if first-uri `(("first" ,first-uri "Back to first")))
 738                                            ,@(if prev-uri `(("prev" ,prev-uri "Previous" :nofollow t)))
 739                                            ("top" "#top" "Back to top")
 740                                            ,@(if next-uri `(("next" ,next-uri "Next" :nofollow t)))
 741                                            ,@(if last-uri `(("last" ,last-uri "Last" :nofollow t))))))
 742         (format out-stream "<script>document.querySelectorAll('#bottom-bar').forEach(bb => { bb.classList.add('decorative'); });</script>")))))
 743
 744 (defun map-output (out-stream fn list)
 745   (loop for item in list do (write-string (funcall fn item) out-stream)))
 746
 747 (defmacro with-outputs ((out-stream) &body body)
 748   (alexandria:with-gensyms (stream-sym)
 749                            (let ((out-body (map 'list (lambda (x) `(princ ,x ,stream-sym)) body)))
 750                              `(let ((,stream-sym ,out-stream))
 751                                 ,.out-body))))
 752
 753 (defun call-with-emit-page (out-stream fn &key title description current-uri content-class (return-code 200) robots (pagination (pagination-nav-bars)) top-nav)
 754   (declare (ignore return-code))
 755   (ignore-errors
 756     (log-conditions
 757       (html-body out-stream
 758                  (lambda ()
 759                    (when top-nav (funcall top-nav out-stream))
 760                    (funcall pagination out-stream fn))
 761                  :title title :description description :current-uri current-uri :content-class content-class :robots robots)
 762       (force-output out-stream))))
 763
 764 (defun set-cookie (key value &key (max-age (- (expt 2 31) 1)) (path "/"))
 765   (hunchentoot:set-cookie key :value value :path path :max-age max-age :secure (site-secure *current-site*)))
 766
 767 (defun set-default-headers (return-code)
 768   (let ((push-option (if (hunchentoot:cookie-in "push") '("nopush"))))
 769     (setf (hunchentoot:content-type*) "text/html; charset=utf-8"
 770           (hunchentoot:return-code*) return-code
 771           (hunchentoot:header-out :link) (format nil "~:{<~A>;rel=preload;type=~A;as=~A~@{;~A~}~:^,~}"
 772                                                  `((,(generate-css-link) "text/css" "style" ,.push-option)
 773                                                    ,.(loop for link in (generate-fonts-links)
 774                                                            collect (list* link "text/css" "style" push-option))
 775                                                    (,(generate-versioned-link "/script.js") "text/javascript" "script" ,.push-option))))
 776     (unless push-option (set-cookie "push" "t" :max-age (* 4 60 60)))))
 777
 778 (defun user-pref (key)
 779   (or (cdr (assoc key *current-prefs*))
 780       (cdr (assoc key *default-prefs*))))
 781
 782 (defun set-user-pref (key value)
 783   (assert (boundp 'hunchentoot:*reply*))
 784   (setf *current-prefs* (remove-duplicates (acons key value *current-prefs*) :key #'car :from-end t))
 785   (set-cookie "prefs" (quri:url-encode (json:encode-json-to-string *current-prefs*))))
 786
 787 (defmacro with-response-stream ((out-stream) &body body) `(call-with-response-stream (lambda (,out-stream) ,.body)))
 788
 789 (defun call-with-response-stream (fn)
 790   (let ((*html-output* (make-flexi-stream (hunchentoot:send-headers) :external-format :utf-8)))
 791     (funcall fn *html-output*)))
 792
 793 (defmacro emit-page ((out-stream &rest args &key (return-code 200) &allow-other-keys) &body body)
 794   (alexandria:once-only (return-code)
 795     `(progn
 796        (set-default-headers ,return-code)
 797        (with-response-stream (,out-stream)
 798          (call-with-emit-page ,out-stream
 799                               (lambda () ,@body)
 800                               ,@args)))))
 801
 802 (defun call-with-error-page (fn)
 803   (let* ((lw2-status
 804            (alexandria:if-let (status-string (hunchentoot:cookie-in "lw2-status"))
 805              (if (string= status-string "") nil
 806                  (let ((json:*identifier-name-to-key* #'json:safe-json-intern))
 807                    (json:decode-json-from-string status-string)))))
 808          (*current-prefs*
 809            (alexandria:if-let (prefs-string (hunchentoot:cookie-in "prefs"))
 810              (let ((json:*identifier-name-to-key* 'json:safe-json-intern))
 811                (ignore-errors (json:decode-json-from-string (quri:url-decode prefs-string)))))))
 812     (with-site-context ((let ((host (or (hunchentoot:header-in* :x-forwarded-host) (hunchentoot:header-in* :host))))
 813                           (or (find-site host)
 814                               (error "Unknown site: ~A" host))))
 815       (multiple-value-bind (*current-auth-token* *current-userid* *current-username*)
 816         (if *read-only-mode*
 817             (values)
 818             (alexandria:if-let
 819               (auth-token
 820                 (alexandria:if-let
 821                   (at (hunchentoot:cookie-in "lw2-auth-token"))
 822                   (if (or (string= at "") (not lw2-status) (> (get-unix-time) (- (cdr (assoc :expires lw2-status)) (* 60 60 24))))
 823                       nil at)))
 824               (with-cache-readonly-transaction
 825                 (values
 826                   auth-token
 827                   (cache-get "auth-token-to-userid" auth-token)
 828                   (cache-get "auth-token-to-username" auth-token)))))
 829         (let ((*current-user-slug* (and *current-userid* (get-user-slug *current-userid*))))
 830           (handler-case
 831             (log-conditions
 832               (funcall fn))
 833             (serious-condition (condition)
 834               (emit-page (out-stream :title "Error" :return-code (condition-http-return-code condition) :content-class "error-page")
 835                          (error-to-html out-stream condition)))))))))
 836
 837 (defmacro with-error-page (&body body)
 838   `(call-with-error-page (lambda () ,@body)))
 839
 840 (defun output-form (out-stream method action id heading csrf-token fields button-label &key textarea end-html)
 841   (format out-stream "<form method=\"~A\" action=\"~A\" id=\"~A\"><h1>~A</h1>" method action id heading)
 842   (loop for (id label type . params) in fields
 843         do (format out-stream "<label for=\"~A\">~A:</label>" id label)
 844         do (cond
 845              ((string= type "select")
 846               (destructuring-bind (option-list &optional default) params
 847                 (format out-stream "<select name=\"~A\">" id)
 848                 (loop for (value label) in option-list
 849                       do (format out-stream "<option value=\"~A\"~:[~; selected~]>~A</option>" value (string= default value) label))
 850                 (format out-stream "</select>")))
 851              (t
 852                (destructuring-bind (&optional (autocomplete "off") default) params
 853                  (format out-stream "<input type=\"~A\" name=\"~A\" autocomplete=\"~A\"~@[ value=\"~A\"~]>" type id autocomplete (and default (encode-entities default))))))
 854         do (format out-stream ""))
 855   (if textarea
 856     (destructuring-bind (ta-name ta-contents) textarea
 857       (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))))
 858   (format out-stream "<input type=\"hidden\" name=\"csrf-token\" value=\"~A\"><input type=\"submit\" value=\"~A\">~@[~A~]</form>"
 859           csrf-token button-label end-html))
 860
 861 (defun page-toolbar-to-html (out-stream &key title new-post new-conversation logout (rss t))
 862   (let ((liu (logged-in-userid)))
 863     (format out-stream "<div class=\"page-toolbar\">")
 864     (when logout
 865       (format out-stream "<form method=\"post\" action=\"/logout\"><button class=\"logout-button button\" name=\"logout\" value=\"~A\">Log out</button></form>"
 866               (make-csrf-token)))
 867     (when (and new-conversation liu)
 868       (multiple-value-bind (text to)
 869         (typecase new-conversation (string (values "Send private message" new-conversation)) (t "New conversation"))
 870         (format out-stream "<a class=\"new-private-message button\" href=\"/conversation~@[?to=~A~]\">~A</a>"
 871                 to text)))
 872     (when (and new-post liu)
 873       (format out-stream "<a class=\"new-post button\" href=\"/edit-post~@[?section=~A~]\" accesskey=\"n\" title=\"Create new post [n]\">New post</a>"
 874               (typecase new-post (string new-post) (t nil))))
 875     (when (and title rss)
 876       (format out-stream "<a class=\"rss\" rel=\"alternate\" type=\"application/rss+xml\" title=\"~A RSS feed\" href=\"~A\">RSS</a>"
 877               title (replace-query-params (hunchentoot:request-uri*) "offset" nil "format" "rss")))
 878     (format out-stream "</div>")))
 879
 880 (defun view-items-index (items &key section title current-uri hide-title need-auth (pagination (pagination-nav-bars)) (top-nav (lambda (s) (page-toolbar-to-html s :title title))) (content-class "index-page"))
 881   (alexandria:switch ((hunchentoot:get-parameter "format") :test #'string=)
 882                      ("rss"
 883                       (setf (hunchentoot:content-type*) "application/rss+xml; charset=utf-8")
 884                       (with-response-stream (out-stream)
 885                         (write-index-items-to-rss out-stream items :title title)))
 886                      (t
 887                        (emit-page (out-stream :title (if hide-title nil title) :description (site-description *current-site*) :content-class content-class
 888                                               :current-uri current-uri :robots (if (hunchentoot:get-parameter :offset) "noindex, nofollow")
 889                                               :pagination pagination :top-nav top-nav)
 890                                   (write-index-items-to-html out-stream items
 891                                                              :need-auth need-auth
 892                                                              :skip-section section)))))
 893
 894 (defun link-if-not (stream linkp url class text &key accesskey nofollow)
 895   (declare (dynamic-extent linkp url text))
 896   (if (not linkp)
 897       (format stream "<a href=\"~A\" class=\"~A\"~@[ accesskey=\"~A\"~]~:[~; rel=\"nofollow\"~]>~A</a>" url class accesskey nofollow text)
 898       (format stream "<span class=\"~A\">~A</span>" class text)))
 899
 900 (defun postprocess-markdown (markdown)
 901   (ppcre:regex-replace-all (concatenate 'string (ppcre:regex-replace-all "\\." (site-uri *current-site*) "\\.") "posts/([^/ ]{17})/([^/# ]*)(?:#comment-([^/ ]{17})|/comment/([^/ ]{17}))?")
 902                            markdown
 903                            (lambda (target-string start end match-start match-end reg-starts reg-ends)
 904                              (declare (ignore start end match-start match-end))
 905                              (labels ((reg (n) (if (and (> (length reg-starts) n) (aref reg-starts n))
 906                                                    (substring target-string (aref reg-starts n) (aref reg-ends n)))))
 907                                (format nil "https://www.lesswrong.com/posts/~A/~A~@[#~A~]" (reg 0) (reg 1) (or (reg 2) (reg 3)))))))
 908
 909 (defun post-or-get-parameter (name)
 910   (or (hunchentoot:post-parameter name) (hunchentoot:get-parameter name)))
 911
 912 (defun redirect (uri &key (type :see-other))
 913   (setf (hunchentoot:return-code*) (ecase type (:see-other 303) (:permanent 301))
 914         (hunchentoot:header-out "Location") uri))
 915
 916 (defmacro define-page (name path-specifier additional-vars &body body)
 917   (labels ((make-lambda (args)
 918              (loop for a in args
 919                    collect (if (atom a) a (first a))))
 920            (filter-plist (plist &rest args)
 921              (declare (dynamic-extent args))
 922              (map-plist (lambda (key val) (when (member key args) (list key val))) plist))
 923            (make-hunchentoot-lambda (args)
 924              (loop for x in args
 925                    collect (if (atom x) x
 926                                (cons (first x) (filter-plist (rest x) :request-type :real-name)))))
 927            (make-binding-form (additional-vars body &aux var-bindings additional-declarations additional-preamble)
 928              (loop for x in additional-vars do
 929                    (destructuring-bind (name &key member type default required request-type real-name) (if (atom x) (list x) x)
 930                      (declare (ignore request-type real-name))
 931                      (let* ((inner-form
 932                               (cond
 933                                 (member
 934                                   `(let ((sym (find-symbol (string-upcase ,name) ,(find-package '#:keyword))))
 935                                      (if (member sym (quote ,member)) sym)))
 936                                 ((and type (subtypep type 'integer))
 937                                  `(if ,name (parse-integer ,name)))))
 938                             (inner-form
 939                               (if default
 940                                   `(or ,inner-form ,default)
 941                                   inner-form)))
 942                        (when required
 943                          (push `(unless (and ,name (not (equal ,name ""))) (error "Missing required parameter: ~A" (quote ,name)))
 944                                additional-preamble))
 945                        (if member
 946                            (if type (error "Cannot specify both member and type.")
 947                                (push `(type (or null symbol) ,name) additional-declarations))
 948                            (if type
 949                                (push `(type (or null ,type) ,name) additional-declarations)
 950                                (push `(type (or null simple-string) ,name) additional-declarations)))
 951                        (when inner-form
 952                          (push `(,name ,inner-form) var-bindings)))))
 953              `(let ,var-bindings (declare ,@additional-declarations) ,@additional-preamble ,@body)))
 954    (multiple-value-bind (path-specifier-form path-bindings-wrapper specifier-vars)
 955     (if (stringp path-specifier)
 956         (values path-specifier #'identity)
 957         (destructuring-bind (specifier-type specifier-body &rest specifier-args) path-specifier
 958           (ecase specifier-type
 959             (:function
 960               (values `(lambda (r) (funcall ,specifier-body (hunchentoot:request-uri r)))
 961                       (if specifier-args
 962                           (lambda (body) `(multiple-value-bind ,(make-lambda specifier-args) (funcall ,specifier-body (hunchentoot:request-uri*)) ,body))
 963                           #'identity)
 964                       specifier-args))
 965             (:regex
 966               (let ((fn `(lambda (r) (ppcre:scan-to-strings ,specifier-body (hunchentoot:request-uri r)))))
 967                 (values fn
 968                         (lambda (body)
 969                           (alexandria:with-gensyms (result-vector)
 970                             `(let ((,result-vector (nth-value 1 (funcall ,fn hunchentoot:*request*))))
 971                                (declare (type simple-vector ,result-vector))
 972                                (let
 973                                  ,(loop for v in (make-lambda specifier-args) as x from 0 collecting `(,v (if (> (length ,result-vector) ,x) (aref ,result-vector ,x))))
 974                                  ,body))))
 975                         specifier-args))))))
 976     (let* ((rewritten-body
 977              (if (string= (ignore-errors (caar body)) "REQUEST-METHOD")
 978                  (progn
 979                    (unless (= (length body) 1)
 980                      (error "REQUEST-METHOD must be the only form when it appears in DEFINE-PAGE."))
 981                    `((ecase (hunchentoot:request-method*)
 982                        ,.(loop for method-body in (cdar body)
 983                                collect (destructuring-bind (method args &body inner-body) method-body
 984                                          (unless (eq method :get)
 985                                            (alexandria:with-gensyms (csrf-token)
 986                                              (push `(,csrf-token :real-name "csrf-token" :required t) args)
 987                                              (push `(check-csrf-token ,csrf-token) inner-body)))
 988                                          (loop for a in args
 989                                                do (push (append (if (atom a) (list a) (cons (first a) (filter-plist (rest a) :real-name))) (list :request-type method)) additional-vars))
 990                                          `(,method ,(make-binding-form args inner-body)))))))
 991                  body)))
 992       `(hunchentoot:define-easy-handler (,name :uri ,path-specifier-form) ,(make-hunchentoot-lambda additional-vars)
 993                                         (with-error-page
 994                                           (block nil
 995                                                  ,(funcall path-bindings-wrapper
 996                                                            (make-binding-form (append specifier-vars additional-vars)
 997                                                                               rewritten-body)))))))))
 998
 999 (define-component sort-widget (&key (sort-options '(:new :hot)) (pref :default-sort) (param-name "sort") (html-class "sort"))
1000   (:http-args '((sort :alias param-name :member sort-options)))
1001   (let ((sort-string (if sort (string-downcase sort))))
1002     (if sort-string
1003         (set-user-pref :default-sort sort-string))
1004     (renderer (out-stream)
1005       (sublevel-nav-to-html out-stream
1006                             sort-options
1007                             (user-pref pref)
1008                             :param-name param-name
1009                             :extra-class html-class))
1010     (or sort-string (user-pref pref))))
1011
1012 (define-page view-root "/" ((offset :type fixnum)
1013                             (limit :type fixnum))
1014   (component-value-bind ((sort-string sort-widget))
1015     (multiple-value-bind (posts total)
1016       (get-posts-index :offset offset :limit (or limit (user-pref :items-per-page)) :sort sort-string)
1017       (view-items-index posts
1018                         :section :frontpage :title "Frontpage posts" :hide-title t
1019                         :pagination (pagination-nav-bars :offset (or offset 0) :total total)
1020                         :top-nav (lambda (out-stream)
1021                                    (page-toolbar-to-html out-stream
1022                                                          :title "Frontpage posts"
1023                                                          :new-post t)
1024                                    (funcall sort-widget out-stream))))))
1025
1026 (define-page view-index "/index" ((view :member (:all :new :frontpage :featured :meta :community :alignment-forum) :default :all)
1027                                   before after
1028                                   (offset :type fixnum)
1029                                   (limit :type fixnum))
1030   (when (eq view :new) (redirect (replace-query-params (hunchentoot:request-uri*) "view" "all" "all" nil) :type :permanent) (return))
1031   (component-value-bind ((sort-string sort-widget))
1032     (multiple-value-bind (posts total)
1033       (get-posts-index :view (string-downcase view) :before before :after after :offset offset :limit (or limit (user-pref :items-per-page)) :sort sort-string)
1034       (let ((page-title (format nil "~@(~A posts~)" view)))
1035         (view-items-index posts
1036                           :section view :title page-title
1037                           :pagination (pagination-nav-bars :offset (or offset 0) :total total)
1038                           :content-class (format nil "index-page ~(~A~)-index-page" view)
1039                           :top-nav (lambda (out-stream)
1040                                      (page-toolbar-to-html out-stream
1041                                                            :title page-title
1042                                                            :new-post (if (eq view :meta) "meta" t))
1043                                      (if (member view '(:all))
1044                                          (funcall sort-widget out-stream))))))))
1045
1046 (define-page view-post "/post" ((id :required t))
1047   (redirect (generate-post-link id) :type :permanent))
1048
1049 (define-page view-post-lw1-link (:function #'match-lw1-link) ()
1050   (redirect (convert-lw1-link (hunchentoot:request-uri*)) :type :permanent))
1051
1052 (define-page view-post-lw2-slug-link (:function #'match-lw2-slug-link) ()
1053   (redirect (convert-lw2-slug-link (hunchentoot:request-uri*)) :type :see-other))
1054
1055 (define-page view-post-lw2-sequence-link (:function #'match-lw2-sequence-link) ()
1056   (redirect (convert-lw2-sequence-link (hunchentoot:request-uri*)) :type :see-other))
1057
1058 (define-page view-feed "/feed" ()
1059   (redirect "/?format=rss" :type :permanent))
1060
1061 (define-page view-post-lw2-link (:function #'match-lw2-link post-id comment-id) (need-auth chrono)
1062   (request-method
1063     (:get ()
1064      (let ((lw2-auth-token *current-auth-token*))
1065        (labels ((output-comments (out-stream id comments target)
1066                   (format out-stream "<div id=\"~A\" class=\"comments\">" id)
1067                   (with-error-html-block (out-stream)
1068                     (if target
1069                         (comment-thread-to-html out-stream
1070                                                 (lambda ()
1071                                                   (comment-item-to-html
1072                                                     out-stream
1073                                                     target
1074                                                     :extra-html-fn (lambda (c-id)
1075                                                                      (let ((*comment-individual-link* nil))
1076                                                                        (comment-tree-to-html out-stream (make-comment-parent-hash comments) c-id))))))
1077                         (if chrono
1078                             (comment-chrono-to-html out-stream comments)
1079                             (comment-tree-to-html out-stream (make-comment-parent-hash comments)))))
1080                   (format out-stream "</div>"))
1081                 (output-comments-votes (out-stream)
1082                   (handler-case
1083                     (when lw2-auth-token
1084                       (format out-stream "<script>commentVotes=~A</script>"
1085                               (json:encode-json-to-string (get-post-comments-votes post-id lw2-auth-token))))
1086                     (t () nil)))
1087                 (output-post-vote (out-stream)
1088                   (handler-case
1089                     (format out-stream "<script>postVote=~A</script>"
1090                             (json:encode-json-to-string (get-post-vote post-id lw2-auth-token)))
1091                     (t () nil))))
1092          (multiple-value-bind (post title condition)
1093            (handler-case (nth-value 0 (get-post-body post-id :auth-token (and need-auth lw2-auth-token)))
1094              (serious-condition (c) (values nil "Error" c))
1095              (:no-error (post) (values post (cdr (assoc :title post)) nil)))
1096            (if comment-id
1097              (let* ((*comment-individual-link* t)
1098                     (comments (get-post-comments post-id))
1099                     (target-comment (find comment-id comments :key (lambda (c) (cdr (assoc :--id c))) :test #'string=))
1100                     (display-name (get-username (cdr (assoc :user-id target-comment)))))
1101                (emit-page (out-stream :title (format nil "~A comments on ~A" display-name title) :content-class "individual-thread-page comment-thread-page")
1102                           (format out-stream "<h1 class=\"post-title\">~A comments on <a href=\"~A\">~A</a></h1>"
1103                                   (encode-entities display-name)
1104                                   (generate-post-link post-id)
1105                                   (clean-text-to-html title))
1106                           (output-comments out-stream "comments" comments target-comment)
1107                           (when lw2-auth-token
1108                             (force-output out-stream)
1109                             (output-comments-votes out-stream))))
1110              (emit-page (out-stream :title title :content-class (format nil "post-page comment-thread-page~:[~; question-post-page~]" (cdr (assoc :question post))))
1111                         (cond
1112                           (condition
1113                             (error-to-html out-stream condition))
1114                           (t
1115                            (post-body-to-html out-stream post)))
1116                         (when (and lw2-auth-token (equal (logged-in-userid) (cdr (assoc :user-id post))))
1117                           (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>"
1118                                   (cdr (assoc :--id post))))
1119                         (force-output out-stream)
1120                         (handler-case
1121                             (let* ((question (cdr (assoc :question post)))
1122                                    (answers (when question
1123                                               (get-post-answers post-id)))
1124                                    (comments (get-post-comments post-id)))
1125                               (when question
1126                                 (output-comments out-stream "answers" answers nil))
1127                               (output-comments out-stream "comments" comments nil))
1128                           (serious-condition (c) (error-to-html out-stream c)))
1129                         (when lw2-auth-token
1130                           (force-output out-stream)
1131                           (output-post-vote out-stream)
1132                           (output-comments-votes out-stream))))))))
1133     (:post (csrf-token text answer parent-comment-id edit-comment-id retract-comment-id unretract-comment-id delete-comment-id)
1134      (let ((lw2-auth-token *current-auth-token*))
1135        (check-csrf-token csrf-token)
1136        (assert lw2-auth-token)
1137        (let ((new-comment-id
1138               (cond
1139                 (text
1140                  (let ((comment-data
1141                         (remove-if #'null
1142                                    `(("body" . ,(postprocess-markdown text))
1143                                      (:last-edited-as . "markdown")
1144                                      ,(if (not edit-comment-id) `(:post-id . ,post-id))
1145                                      ,(if parent-comment-id `(:parent-comment-id . ,parent-comment-id))
1146                                      ,(if answer `(:answer . t))))))
1147                    (if edit-comment-id
1148                        (prog1 edit-comment-id
1149                          (do-lw2-comment-edit lw2-auth-token edit-comment-id comment-data))
1150                        (do-lw2-comment lw2-auth-token comment-data))))
1151                 (retract-comment-id
1152                  (do-lw2-comment-edit lw2-auth-token retract-comment-id '((:retracted . t))))
1153                 (unretract-comment-id
1154                  (do-lw2-comment-edit lw2-auth-token unretract-comment-id '((:retracted . nil))))
1155                 (delete-comment-id
1156                  (do-lw2-comment-edit lw2-auth-token delete-comment-id '((:deleted . t) (:deleted-public . t)
1157                                                                          (:deleted-reason . "Comment deleted by its author.")))
1158                  nil))))
1159          (ignore-errors (get-post-comments post-id :force-revalidate t))
1160          (when text
1161            (cache-put "comment-markdown-source" new-comment-id text)
1162            (redirect (generate-post-link (match-lw2-link (hunchentoot:request-uri*)) new-comment-id))))))))
1163
1164 (defparameter *edit-post-template* (compile-template* "edit-post.html"))
1165
1166 (define-page view-edit-post "/edit-post" (title url section post-id link-post)
1167   (request-method
1168     (:get ()
1169      (let* ((csrf-token (make-csrf-token))
1170             (post-body (if post-id (get-post-body post-id :auth-token (hunchentoot:cookie-in "lw2-auth-token"))))
1171             (section (or section (loop for (sym . sec) in '((:draft . "drafts") (:meta . "meta") (:frontpage-date . "frontpage"))
1172                                        if (cdr (assoc sym post-body)) return sec
1173                                        finally (return "all")))))
1174        (emit-page (out-stream :title (if post-id "Edit Post" "New Post") :content-class "edit-post-page")
1175                   (render-template* *edit-post-template* out-stream
1176                                     :csrf-token csrf-token
1177                                     :title (cdr (assoc :title post-body))
1178                                     :url (cdr (assoc :url post-body))
1179                                     :question (cdr (assoc :question post-body))
1180                                     :post-id post-id
1181                                     :section-list (loop for (name desc) in '(("all" "All") ("meta" "Meta") ("drafts" "Drafts"))
1182                                                         collect (alist :name name :desc desc :selected (string= name section)))
1183                                     :markdown-source (or (and post-id (cache-get "post-markdown-source" post-id)) (cdr (assoc :html-body post-body)) "")))))
1184     (:post ((text :required t) question)
1185      (let ((lw2-auth-token *current-auth-token*)
1186            (url (if (string= url "") nil url)))
1187        (assert lw2-auth-token)
1188        (let* ((post-data `(("body" . ,(postprocess-markdown text)) ("title" . ,title) (:last-edited-as . "markdown") ("url" . ,(if link-post url))
1189                            ("meta" . ,(string= section "meta")) ("draft" . ,(string= section "drafts"))
1190                            ("question" . ,(if question t nil))))
1191               (post-set (loop for item in post-data when (cdr item) collect item))
1192               (post-unset (loop for item in post-data when (not (cdr item)) collect (cons (car item) t))))
1193          (let* ((new-post-data
1194                   (if post-id
1195                       (do-lw2-post-edit lw2-auth-token post-id post-set post-unset)
1196                       (do-lw2-post lw2-auth-token post-set)))
1197                 (new-post-id (cdr (assoc :--id new-post-data))))
1198            (assert new-post-id)
1199            (cache-put "post-markdown-source" new-post-id text)
1200            (ignore-errors (get-post-body post-id :force-revalidate t))
1201            (redirect (if (cdr (assoc "draft" post-data :test #'equal))
1202                          (concatenate 'string (generate-post-link new-post-data) "?need-auth=y")
1203                          (generate-post-link new-post-data)))))))))
1204
1205 (hunchentoot:define-easy-handler (view-karma-vote :uri "/karma-vote") ((csrf-token :request-type :post) (target :request-type :post) (target-type :request-type :post) (vote-type :request-type :post))
1206   (with-error-page
1207     (check-csrf-token csrf-token)
1208     (let ((lw2-auth-token (hunchentoot:cookie-in "lw2-auth-token")))
1209       (multiple-value-bind (points vote-type) (do-lw2-vote lw2-auth-token target target-type vote-type)
1210         (json:encode-json-to-string (list (pretty-number points "point") vote-type))))))
1211
1212 (hunchentoot:define-easy-handler (view-check-notifications :uri "/check-notifications") ()
1213                                  (with-error-page
1214                                    (if *current-auth-token*
1215                                        (let ((notifications-status (check-notifications (logged-in-userid) *current-auth-token*)))
1216                                          (json:encode-json-to-string notifications-status)))))
1217
1218 (define-page view-recent-comments "/recentcomments" ((offset :type fixnum)
1219                                                      (limit :type fixnum))
1220   (let ((want-total (not (typep *current-backend* 'backend-lw2)))) ; jumping to last page causes LW2 to explode
1221     (multiple-value-bind (recent-comments total)
1222       (if (or offset limit (/= (user-pref :items-per-page) 20))
1223           (lw2-graphql-query (lw2-query-string :comment :list
1224                                                (remove nil (alist :view "postCommentsNew" :limit (or limit (user-pref :items-per-page)) :offset offset)
1225                                                        :key #'cdr)
1226                                                *comments-index-fields*
1227                                                :with-total want-total))
1228           (get-recent-comments :with-total want-total))
1229       (view-items-index recent-comments :title "Recent comments" :pagination (pagination-nav-bars :offset (or offset 0) :with-next (not want-total) :total (if want-total total))))))
1230
1231 (define-page view-user (:regex "^/users/(.*?)(?:$|\\?)|^/user" user-slug) (id
1232                                                                              (offset :type fixnum :default 0)
1233                                                                              (show :member (:all :posts :comments :drafts :conversations :inbox) :default :all)
1234                                                                              (sort :member (:top :new) :default :new))
1235              (let* ((auth-token (if (eq show :inbox) *current-auth-token*))
1236                     (user-query-terms (cond
1237                                         (user-slug (alist :slug user-slug))
1238                                         (id (alist :document-id id))))
1239                     (user-info
1240                       (let ((ui (lw2-graphql-query (lw2-query-string :user :single user-query-terms `(:--id :slug :display-name :karma ,@(if (eq show :inbox) '(:last-notifications-check))))
1241                                                    :auth-token auth-token)))
1242                         (if (cdr (assoc :--id ui))
1243                             ui
1244                             (error (make-condition 'lw2-user-not-found-error)))))
1245                     (user-id (cdr (assoc :--id user-info)))
1246                     (own-user-page (logged-in-userid user-id))
1247                     (comments-index-fields (remove :page-url *comments-index-fields*)) ; page-url sometimes causes "Cannot read property '_id' of undefined" error
1248                     (display-name (if user-slug (cdr (assoc :display-name user-info)) user-id))
1249                     (show-text (if (not (eq show :all)) (string-capitalize show)))
1250                     (title (format nil "~A~@['s ~A~]" display-name show-text))
1251                     (sort-type (case sort (:top :score) (:new :date)))
1252                     (comments-base-terms (ecase sort-type (:score (load-time-value (alist :view "postCommentsTop"))) (:date (load-time-value (alist :view "allRecentComments"))))))
1253                (multiple-value-bind (items total)
1254                  (case show
1255                    (:posts
1256                      (get-user-posts user-id :offset offset :limit (+ 1 (user-pref :items-per-page)) :sort-type sort-type))
1257                    (:comments
1258                      (lw2-graphql-query (lw2-query-string :comment :list
1259                                                           (nconc (alist :offset offset :limit (+ 1 (user-pref :items-per-page)) :user-id user-id)
1260                                                                  comments-base-terms)
1261                                                           comments-index-fields)))
1262                    (:drafts
1263                      (get-user-posts user-id :drafts t :auth-token (hunchentoot:cookie-in "lw2-auth-token")))
1264                    (:conversations
1265                      (let ((conversations
1266                              (lw2-graphql-query (lw2-query-string :conversation :list
1267                                                                   (alist :view "userConversations" :limit (+ 1 (user-pref :items-per-page)) :offset offset :user-id user-id)
1268                                                                   '(:--id :created-at :title (:participants :display-name :slug) :----typename))
1269                                                 :auth-token (hunchentoot:cookie-in "lw2-auth-token"))))
1270                        (lw2-graphql-query-map
1271                          (lambda (c)
1272                            (lw2-query-string* :message :total (alist :view "messagesConversation" :conversation-id (cdr (assoc :--id c))) nil))
1273                          conversations
1274                          :postprocess (lambda (c result)
1275                                         (acons :messages-total result c))
1276                          :auth-token (hunchentoot:cookie-in "lw2-auth-token"))))
1277                    (:inbox
1278                      (prog1
1279                        (let ((notifications (get-notifications :user-id user-id :offset offset :auth-token (hunchentoot:cookie-in "lw2-auth-token")))
1280                              (last-check (ignore-errors (local-time:parse-timestring (cdr (assoc :last-notifications-check user-info))))))
1281                          (labels ((check-new (key obj)
1282                                     (if (ignore-errors (local-time:timestamp< last-check (local-time:parse-timestring (cdr (assoc key obj)))))
1283                                         (acons :highlight-new t obj)
1284                                         obj)))
1285                            (lw2-graphql-query-map
1286                              (lambda (n)
1287                                (alexandria:switch ((cdr (assoc :document-type n)) :test #'string=)
1288                                                   ("comment"
1289                                                    (lw2-query-string* :comment :single
1290                                                                       (alist :document-id (cdr (assoc :document-id n)))
1291                                                                       *comments-index-fields*))
1292                                                   ("post"
1293                                                    (lw2-query-string* :post :single (alist :document-id (cdr (assoc :document-id n)))
1294                                                                       *posts-index-fields*))
1295                                                   ("message"
1296                                                    (lw2-query-string* :message :single (alist :document-id (cdr (assoc :document-id n)))
1297                                                                       *messages-index-fields*))
1298                                                   (t
1299                                                     (values n t))))
1300                              notifications
1301                              :postprocess (lambda (n result)
1302                                             (if result
1303                                                 (check-new
1304                                                   (alexandria:switch ((cdr (assoc :document-type n)) :test #'string=)
1305                                                                      ("comment" :posted-at)
1306                                                                      ("post" :posted-at)
1307                                                                      ("message" :created-at))
1308                                                   result)
1309                                                 n))
1310                              :auth-token auth-token)))
1311                        (do-user-edit (hunchentoot:cookie-in "lw2-auth-token") user-id (alist :last-notifications-check (local-time:format-timestring nil (local-time:now)
1312                                                                                                                                                      :format lw2.graphql:+graphql-timestamp-format+
1313                                                                                                                                                      :timezone local-time:+utc-zone+)))))
1314                    (t
1315                      (let ((user-posts (get-user-posts user-id :limit (+ 1 (user-pref :items-per-page) offset)))
1316                            (user-comments (lw2-graphql-query (lw2-query-string :comment :list (nconc (alist :limit (+ 1 (user-pref :items-per-page) offset) :user-id user-id) comments-base-terms)
1317                                                                                comments-index-fields))))
1318                        (concatenate 'list user-posts user-comments))))
1319                  (let ((with-next (> (length items) (+ (if (eq show :all) offset 0) (user-pref :items-per-page))))
1320                        (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
1321                    (view-items-index interleave :title title
1322                                      :content-class (format nil "user-page~@[ ~A-user-page~]~:[~; own-user-page~]" show-text own-user-page)
1323                                      :current-uri (format nil "/users/~A" user-slug)
1324                                      :section :personal
1325                                      :pagination (pagination-nav-bars :offset offset :total total :with-next (if (not total) with-next))
1326                                      :need-auth (eq show :drafts) :section (if (eq show :drafts) "drafts" nil)
1327                                      :top-nav (lambda (out-stream)
1328                                                 (page-toolbar-to-html out-stream
1329                                                                       :title title
1330                                                                       :rss (not (member show '(:drafts :conversations :inbox)))
1331                                                                       :new-post (if (eq show :drafts) "drafts" t)
1332                                                                       :new-conversation (if own-user-page t user-slug)
1333                                                                       :logout own-user-page)
1334                                                 (format out-stream "<h1 class=\"page-main-heading\"~@[ ~A~]>~A</h1><div class=\"user-stats\">Karma: <span class=\"karma-total\">~A</span></div>"
1335                                                         (if (not own-user-page)
1336                                                             (if user-slug
1337                                                                 (format nil "data-anti-kibitzer-redirect=\"/user?id=~A\"" (cdr (assoc :--id user-info)))
1338                                                                 (format nil "data-kibitzer-redirect=\"/users/~A\"" (cdr (assoc :slug user-info)))))
1339                                                         (encode-entities display-name)
1340                                                         (if user-slug (pretty-number (or (cdr (assoc :karma user-info)) 0)) "##"))
1341                                                 (sublevel-nav-to-html out-stream
1342                                                                       `(:all :posts :comments
1343                                                                         ,@(if own-user-page
1344                                                                               '(:drafts :conversations :inbox)))
1345                                                                       show
1346                                                                       :default :all)
1347                                                 (when (member show '(:all :posts :comments))
1348                                                   (sublevel-nav-to-html out-stream
1349                                                                         '(:new :top)
1350                                                                         sort
1351                                                                         :default :new
1352                                                                         :param-name "sort"
1353                                                                         :extra-class "sort"))))))))
1354
1355 (defparameter *conversation-template* (compile-template* "conversation.html"))
1356
1357 (define-page view-conversation "/conversation" (id)
1358   (request-method
1359     (:get ()
1360      (let ((to (post-or-get-parameter "to")))
1361        (cond
1362          ((and id to) (error "This is an invalid URL."))
1363          (id
1364            (multiple-value-bind (conversation messages)
1365              (get-conversation-messages id (hunchentoot:cookie-in "lw2-auth-token"))
1366              (view-items-index (nreverse messages) :content-class "conversation-page" :need-auth t :title (encode-entities (postprocess-conversation-title (cdr (assoc :title conversation))))
1367                                :top-nav (lambda (out-stream) (render-template* *conversation-template* out-stream
1368                                                                                :conversation conversation :csrf-token (make-csrf-token))))))
1369          (t
1370           (emit-page (out-stream :title "New conversation" :content-class "conversation-page")
1371                      (render-template* *conversation-template* out-stream
1372                                        :to to
1373                                        :csrf-token (make-csrf-token)))))))
1374     (:post ((text :required t))
1375      (let* ((subject (post-or-get-parameter "subject"))
1376             (to (post-or-get-parameter "to"))
1377             (id (or id
1378                     (let ((participant-ids (list (logged-in-userid) (cdar (lw2-graphql-query (lw2-query-string :user :single (alist :slug to) '(:--id)))))))
1379                       (do-create-conversation (hunchentoot:cookie-in "lw2-auth-token") (alist :participant-ids participant-ids :title subject))))))
1380        (do-create-message (hunchentoot:cookie-in "lw2-auth-token") id text)
1381        (redirect (format nil "/conversation?id=~A" id))))))
1382
1383 (defun search-result-markdown-to-html (item)
1384   (cons (cons :html-body
1385               (handler-case (markdown:parse (cdr (assoc :body item)))
1386                 (serious-condition () "[Error while processing search result]")))
1387         item))
1388
1389 (define-page view-search "/search" ((q :required t))
1390   (let ((*current-search-query* q)
1391         (link (convert-any-link* q)))
1392     (declare (special *current-search-query*))
1393     (if link
1394         (redirect link)
1395         (multiple-value-bind (posts comments) (lw2-search-query q)
1396           (view-items-index (nconc (map 'list (lambda (p) (if (cdr (assoc :comment-count p)) p (cons (cons :comment-count 0) p))) posts)
1397                                    (map 'list #'search-result-markdown-to-html comments))
1398                             :content-class "search-results-page" :current-uri "/search"
1399                             :title (format nil "~@[~A - ~]Search" q))))))
1400
1401 (define-page view-login "/login" (return cookie-check
1402                                          (csrf-token :request-type :post) (login-username :request-type :post) (login-password :request-type :post)
1403                                          (signup-username :request-type :post) (signup-email :request-type :post) (signup-password :request-type :post) (signup-password2 :request-type :post))
1404   (labels
1405     ((emit-login-page (&key error-message)
1406        (let ((csrf-token (make-csrf-token)))
1407          (emit-page (out-stream :title "Log in" :current-uri "/login" :content-class "login-page" :robots "noindex, nofollow")
1408                     (when error-message
1409                       (format out-stream "<div class=\"error-box\">~A</div>" error-message))
1410                     (with-outputs (out-stream) "<div class=\"login-container\">")
1411                     (output-form out-stream "post" (format nil "/login~@[?return=~A~]" (if return (url-rewrite:url-encode return))) "login-form" "Log in" csrf-token
1412                                  '(("login-username" "Username" "text" "username")
1413                                    ("login-password" "Password" "password" "current-password"))
1414                                  "Log in"
1415                                  :end-html "<a href=\"/reset-password\">Forgot password</a>")
1416                     (output-form out-stream "post" (format nil "/login~@[?return=~A~]" (if return (url-rewrite:url-encode return))) "signup-form" "Create account" csrf-token
1417                                  '(("signup-username" "Username" "text" "username")
1418                                    ("signup-email" "Email" "text" "email")
1419                                    ("signup-password" "Password" "password" "new-password")
1420                                    ("signup-password2" "Confirm password" "password" "new-password"))
1421                                  "Create account")
1422                     (alexandria:if-let (main-site-title (main-site-title *current-site*))
1423                       (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>"
1424                               main-site-title))
1425                     (format out-stream "</div>"))))
1426      (finish-login (username user-id auth-token error-message expires)
1427        (cond
1428          (auth-token
1429            (set-cookie "lw2-auth-token" auth-token :max-age (and expires (+ (- expires (get-unix-time)) (* 24 60 60))))
1430            (if expires (set-cookie "lw2-status" (json:encode-json-to-string (alist :expires expires))))
1431            (cache-put "auth-token-to-userid" auth-token user-id)
1432            (cache-put "auth-token-to-username" auth-token username)
1433            (redirect (if (and return (ppcre:scan "^/[^/]" return)) return "/")))
1434          (t
1435           (emit-login-page :error-message error-message)))))
1436     (cond
1437       ((not (or cookie-check (hunchentoot:cookie-in "session-token")))
1438         (set-cookie "session-token" (base64:usb8-array-to-base64-string (ironclad:make-random-salt)))
1439         (redirect (format nil "/login?~@[return=~A&~]cookie-check=y" (if return (url-rewrite:url-encode return)))))
1440       (cookie-check
1441         (if (hunchentoot:cookie-in "session-token")
1442             (redirect (format nil "/login~@[?return=~A~]" (if return (url-rewrite:url-encode return))))
1443             (emit-page (out-stream :title "Log in" :current-uri "/login")
1444                        (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))))))
1445       (login-username
1446         (check-csrf-token csrf-token)
1447         (cond
1448           ((or (string= login-username "") (string= login-password "")) (emit-login-page :error-message "Please enter a username and password"))
1449           (t (multiple-value-call #'finish-login login-username (do-login "username" login-username login-password)))))
1450       (signup-username
1451         (check-csrf-token csrf-token)
1452         (cond
1453           ((not (every (lambda (x) (not (string= x ""))) (list signup-username signup-email signup-password signup-password2)))
1454            (emit-login-page :error-message "Please fill in all fields"))
1455           ((not (string= signup-password signup-password2))
1456            (emit-login-page :error-message "Passwords do not match"))
1457           (t (multiple-value-call #'finish-login signup-username (do-lw2-create-user signup-username signup-email signup-password)))))
1458       (t
1459        (emit-login-page)))))
1460
1461 (define-page view-logout "/logout" ((logout :request-type :post))
1462   (check-csrf-token logout)
1463   (set-cookie "lw2-auth-token" "" :max-age 0)
1464   (redirect "/"))
1465
1466 (defparameter *reset-password-template* (compile-template* "reset-password.html"))
1467
1468 (define-page view-reset-password "/reset-password" ((csrf-token :request-type :post) (email :request-type :post) (reset-link :request-type :post) (password :request-type :post) (password2 :request-type :post))
1469   (labels ((emit-rpw-page (&key message message-type step)
1470              (let ((csrf-token (make-csrf-token)))
1471                (emit-page (out-stream :title "Reset password" :content-class "reset-password" :robots "noindex, nofollow")
1472                           (render-template* *reset-password-template* out-stream
1473                                             :csrf-token csrf-token
1474                                             :reset-link reset-link
1475                                             :message message
1476                                             :message-type message-type
1477                                             :step step)))))
1478     (cond
1479       (email
1480         (check-csrf-token csrf-token)
1481         (multiple-value-bind (ret error)
1482           (do-lw2-forgot-password email)
1483           (declare (ignore ret))
1484           (if error
1485               (emit-rpw-page :step 1 :message error :message-type "error")
1486               (emit-rpw-page :step 1 :message "Password reset email sent." :message-type "success"))))
1487       (reset-link
1488         (ppcre:register-groups-bind (reset-token) ("(?:reset-password/|^)([^/#]+)$" reset-link)
1489                                     (cond
1490                                       ((not reset-token)
1491                                        (emit-rpw-page :step 2 :message "Invalid password reset link." :message-type "error"))
1492                                       ((not (string= password password2))
1493                                        (emit-rpw-page :step 2 :message "Passwords do not match." :message-type "error"))
1494                                       (t
1495                                        (check-csrf-token csrf-token)
1496                                        (multiple-value-bind (user-id auth-token error-message) (do-lw2-reset-password reset-token password)
1497                                          (declare (ignore user-id auth-token))
1498                                          (cond
1499                                            (error-message (emit-rpw-page :step 2 :message error-message :message-type "error"))
1500                                            (t
1501                                             (with-error-page (emit-page (out-stream :title "Reset password" :content-class "reset-password")
1502                                                                         (format out-stream "<h1>Password reset complete</h1><p>You can now <a href=\"/login\">log in</a> with your new password.</p>"))))))))))
1503       (t
1504        (emit-rpw-page)))))
1505
1506 (defun firstn (list n)
1507   (loop for x in list
1508         for i from 1 to n
1509         collect x))
1510
1511 (defparameter *earliest-post* (local-time:parse-timestring "2005-01-01"))
1512
1513 (define-page view-archive (:regex "^/archive(?:/(\\d{4})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))"
1514                            (year :type (mod 10000))
1515                            (month :type (integer 1 12))
1516                            (day :type (integer 1 31)))
1517              ((offset :type fixnum :default 0))
1518   (local-time:with-decoded-timestamp (:day current-day :month current-month :year current-year) (local-time:now)
1519     (local-time:with-decoded-timestamp (:day earliest-day :month earliest-month :year earliest-year) *earliest-post*
1520       (labels ((url-elements (&rest url-elements)
1521                  (declare (dynamic-extent url-elements))
1522                  (format nil "/~{~A~^/~}" url-elements))
1523                (archive-nav (out-stream)
1524                  (with-outputs (out-stream) "<div class=\"archive-nav\"><div class=\"archive-nav-years\">")
1525                  (link-if-not out-stream (not (or year month day)) (url-elements "archive") "archive-nav-item-year" "All")
1526                  (loop for y from earliest-year to current-year
1527                        do (link-if-not out-stream (eq y year) (url-elements "archive" y) "archive-nav-item-year" y))
1528                  (format out-stream "</div>")
1529                  (when year
1530                    (format out-stream "<div class=\"archive-nav-months\">")
1531                    (link-if-not out-stream (not month) (url-elements "archive" year) "archive-nav-item-month" "All")
1532                    (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)
1533                          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)))
1534                    (format out-stream "</div>"))
1535                  (when month
1536                    (format out-stream "<div class=\"archive-nav-days\">")
1537                    (link-if-not out-stream (not day) (url-elements "archive" year month) "archive-nav-item-day" "All")
1538                    (loop for d from (if (and (= (or year current-year) earliest-year) (= (or month current-month) earliest-month)) earliest-day 1)
1539                          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)))
1540                          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))
1541                    (format out-stream "</div>"))
1542                  (format out-stream "</div>")))
1543         (multiple-value-bind (posts total)
1544           (lw2-graphql-query (lw2-query-string :post :list
1545                                                (alist :view (if day "new" "top") :limit 51 :offset offset
1546                                                       :after (if (and year (not day)) (format nil "~A-~A-~A" (or year earliest-year) (or month 1) (or day 1)))
1547                                                       :before (if year (format nil "~A-~A-~A" (or year current-year) (or month 12)
1548                                                                                (or day (local-time:days-in-month (or month 12) (or year current-year))))))
1549                                                *posts-index-fields*))
1550           (emit-page (out-stream :title "Archive" :current-uri "/archive" :content-class "archive-page"
1551                                  :top-nav #'archive-nav
1552                                  :pagination (pagination-nav-bars :items-per-page 50 :offset offset :total total :with-next (if total nil (> (length posts) 50))))
1553                      (write-index-items-to-html out-stream (firstn posts 50) :empty-message "No posts for the selected period.")))))))
1554
1555 (define-page view-about "/about" ()
1556   (emit-page (out-stream :title "About" :current-uri "/about" :content-class "about-page")
1557              (alexandria:with-input-from-file (in-stream "www/about.html" :element-type '(unsigned-byte 8))
1558                                               (alexandria:copy-stream in-stream out-stream))))
1559
1560 (hunchentoot:define-easy-handler (view-versioned-resource :uri (lambda (r)
1561                                                                  (multiple-value-bind (file content-type)
1562                                                                    #.(labels ((defres (uri content-type)
1563                                                                                 `(,uri (values (concatenate 'string "www" ,uri) ,content-type))))
1564                                                                        (concatenate 'list
1565                                                                                     '(alexandria:switch ((hunchentoot:script-name r) :test #'string=))
1566                                                                                     (loop for system in '("mac" "windows" "linux") nconc
1567                                                                                       (loop for theme in '(nil "dark" "grey" "ultramodern" "zero" "brutalist" "rts")
1568                                                                                             collect (defres (format nil "/style~@[-~A~].~A.css" theme system) "text/css")))
1569                                                                                     (loop for (uri content-type) in
1570                                                                                       '(("/script.js" "text/javascript")
1571                                                                                         ("/favicon.ico" "image/x-icon"))
1572                                                                                       collect (defres uri content-type))))
1573                                                                    (when file
1574                                                                      (when (assoc "v" (hunchentoot:get-parameters r) :test #'string=)
1575                                                                        (setf (hunchentoot:header-out "Cache-Control") (format nil "public, max-age=~A, immutable" (- (expt 2 31) 1))))
1576                                                                      (hunchentoot:handle-static-file file content-type)
1577                                                                      t))))
1578                                  nil)