1 (uiop:define-package
#:lw2-viewer
2 (:use
#:cl
#:sb-thread
#:flexi-streams
#:djula
#:iterate
3 #:lw2-viewer.config
#:lw2.utils
#:lw2.lmdb
#:lw2.backend
#:lw2.links
#:lw2.clean-html
#:lw2.login
#:lw2.context
#:lw2.sites
#:lw2.components
#:lw2.html-reader
#:lw2.fonts
13 #:lw2.data-viewers.post
14 #:lw2.data-viewers.comment
17 (:import-from
#:alexandria
#:with-gensyms
#:once-only
#:ensure-list
#:when-let
#:when-let
* #:if-let
#:alist-hash-table
)
18 (:import-from
#:collectors
#:with-collector
)
19 (:import-from
#:ppcre
#:regex-replace-all
)
21 #:define-regex-handler
#:*fonts-stylesheet-uri
* #:generate-fonts-link
22 #:user-nav-bar
#:*primary-nav
* #:*secondary-nav
* #:*nav-bars
*
23 #:begin-html
#:end-html
24 #:*fonts-stylesheet-uris
* #:*fonts-redirect-data
* #:*fonts-redirect-lock
* #:*fonts-redirect-thread
*
25 #:postprocess-conversation-title
28 #:*extra-external-scripts
* #:*extra-inline-scripts
*
29 #:site-stylesheets
#:site-inline-scripts
#:site-scripts
#:site-external-scripts
#:site-head-elements
34 (:recycle
#:lw2-viewer
#:lw2.backend
))
36 (in-package #:lw2-viewer
)
38 (named-readtables:in-readtable html-reader
)
40 (add-template-directory (asdf:system-relative-pathname
"lw2-viewer" "templates/"))
42 (define-cache-database 'backend-lw2-legacy
43 "auth-token-to-userid" "auth-token-to-username" "user-ignore-list")
45 (defvar *read-only-mode
* nil
)
46 (defvar *read-only-default-message
* "Due to a system outage, you cannot log in or post at this time.")
48 (defparameter *default-prefs
* (alist :items-per-page
20 :default-sort
"new"))
49 (defvar *current-prefs
* nil
)
51 (defun get-post-sequences (post-id)
52 (when-let (sequence-ids (get-post-sequence-ids post-id
))
54 (dolist (sequence-id sequence-ids
)
55 (let* ((sequence (get-sequence sequence-id
))
56 (posts (sequence-post-ids sequence
)))
57 (multiple-value-bind (prev next
)
58 (loop for prev
= nil then
(car current
)
60 when
(string= (car current
) post-id
)
61 return
(values prev
(second current
)))
64 (and prev
(get-sequence-post sequence prev
))
65 (and next
(get-sequence-post sequence next
))))))))
68 (defun rectify-post-relations (post-relations)
69 (remove-if-not (lambda (pr) (cdr (assoc :--id
(cdr (first pr
))))) post-relations
))
71 (defun post-nav-links (post post-sequences
)
72 <nav class
="post-nav-links">
73 (schema-bind (:post post
(target-post-relations source-post-relations
) :context
:body
)
74 (let ((target-post-relations (rectify-post-relations target-post-relations
))
75 (source-post-relations (rectify-post-relations source-post-relations
)))
76 (when (or target-post-relations source-post-relations
)
77 <div class
="related-posts">
78 (dolist (relations `((,source-post-relations
"Parent question")
79 (,target-post-relations
"Sub-question")))
80 (destructuring-bind (related-posts relation-type
) relations
82 <div class
="related-post-group">
83 <div class
="related-post-type">("~A~A" relation-type
(if (second related-posts
) "s" ""))</div
>
84 (dolist (post-relation related-posts
)
85 (post-headline-to-html (or (cdr (assoc :source-post post-relation
))
86 (cdr (assoc :target-post post-relation
)))))
89 (loop for
(sequence prev next
) in post-sequences do
91 <div class
="post-nav-item sequence">
92 <a class
="post-nav sequence-title" href
=("/s/~A" (cdr (assoc :--id sequence
)))>
93 <span class
="post-nav-label">Part of the sequence
:</span
>
94 <span class
="post-nav-title">(safe (clean-text-to-html (cdr (assoc :title sequence
))))</span
>
96 (labels ((post-nav-link (direction post
)
97 <a class
=("post-nav ~A" (string-downcase direction
)) href
=(generate-item-link :post post
)>
98 <span class
="post-nav-label">(case direction
(:prev
"Previous: ") (:next
"Next: "))</span
>
99 <span class
="post-nav-title">(safe (clean-text-to-html (cdr (assoc :title post
))))</span
>
101 (when prev
(post-nav-link :prev prev
))
102 (when next
(post-nav-link :next next
)))
106 (defun rectify-conversation (conversation)
107 (alist-bind ((title (or null string
)))
109 (if (or (null title
) (string= title
""))
110 (acons :title
"[Untitled conversation]" conversation
)
113 (defun conversation-message-to-html (out-stream message
)
114 (alist-bind ((user-id string
)
116 (highlight-new boolean
)
120 (html-body (or string null
)))
122 (let ((conversation (rectify-conversation conversation
)))
123 (multiple-value-bind (pretty-time js-time
) (pretty-time created-at
)
124 (format out-stream
"<div class=\"comment private-message~A\"><div class=\"comment-meta\"><a class=\"author\" href=\"/users/~A\">~A</a> <span class=\"date\" data-js-date=\"~A\">~A~A</span><div class=\"comment-post-title\">Private message in: <a href=\"/conversation?id=~A\">~A</a></div></div><div class=\"body-text comment-body\">"
125 (if highlight-new
" comment-item-highlight" "")
126 (encode-entities (get-user-slug user-id
))
127 (encode-entities (get-username user-id
))
131 (encode-entities (cdr (assoc :--id conversation
)))
132 (encode-entities (cdr (assoc :title conversation
)))))
133 (labels ((ws (html-body) (let ((*memoized-output-stream
* out-stream
)) (clean-html* html-body
))))
135 (contents (ws (cdr (assoc :html contents
))))
136 (html-body (ws html-body
))
137 (t (format out-stream
"~{<p>~A</p>~}" (loop for block in
(cdr (assoc :blocks content
)) collect
(encode-entities (cdr (assoc :text block
))))))))
138 (format out-stream
"</div></div>"))))
140 (defun conversation-index-to-html (out-stream conversation
)
141 (alist-bind ((conversation-id string
:--id
)
142 (title (or null string
))
143 (created-at (or null string
))
145 (messages-total fixnum
))
146 (rectify-conversation conversation
)
147 (multiple-value-bind (pretty-time js-time
) (if created-at
(pretty-time created-at
) (values "[Error]" 0))
148 (format out-stream
"<h1 class=\"listing\"><a href=\"/conversation?id=~A\">~A</a></h1><div class=\"post-meta\"><div class=\"conversation-participants\"><ul>~:{<li><a href=\"/users/~A\">~A</a></li>~}</ul></div><div class=\"messages-count\">~A</div><div class=\"date\" data-js-date=\"~A\">~A~A</div></div>"
149 (encode-entities conversation-id
)
150 (encode-entities title
)
151 (loop for p in participants
152 collect
(list (encode-entities (cdr (assoc :slug p
))) (encode-entities (cdr (assoc :display-name p
)))))
153 (pretty-number messages-total
"message")
158 (defun collection-to-contents (collection &optional
(heading-level 1) (used-anchors (make-hash-table :test
'equal
)))
159 (alist-bind ((title (or string null
)))
161 (let ((subcollections (cdr
162 (find-if (lambda (x) (member (car x
) '(:books
:sequences
:chapters
) :test
#'eq
))
164 contents-head contents-tail
)
165 (labels ((add-contents (c)
168 (setf (cdr contents-tail
) c
)
169 (setf contents-head c
))
170 (setf contents-tail
(last c
)))))
172 ((and title
(not (cdr (assoc :books collection
))))
173 (add-contents (list (list heading-level title
(title-to-anchor title used-anchors
))))
174 (dolist (subcollection subcollections
)
175 (add-contents (collection-to-contents subcollection
(1+ heading-level
) used-anchors
))))
177 (dolist (subcollection subcollections
)
178 (add-contents (collection-to-contents subcollection heading-level used-anchors
)))))
181 (defun collection-to-html (collection &optional
(heading-level 1) (used-anchors (make-hash-table :test
'equal
)))
182 (alist-bind ((title (or string null
))
183 (subtitle (or string null
))
184 (number (or fixnum null
))
188 (let* ((subcollections (cdr
189 (find-if (lambda (x) (member (car x
) '(:books
:sequences
:chapters
) :test
#'eq
))
191 (html-body (cdr (assoc :html contents
))))
193 ((or html-body title posts
)
195 (when (or html-body title
)
196 <div class
="body-text sequence-text">
198 (with-html-stream-output (:stream stream
)
199 (format stream
"<h~A id=\"~A\" class=\"sequence-chapter\">~@[~A. ~]~A</h~A>"
201 (title-to-anchor title used-anchors
)
203 (clean-text-to-html title
)
205 (when (assoc :books collection
)
206 (contents-to-html (collection-to-contents collection
) 1 *html-output
*))
208 <div class
="sequence-subtitle">(safe (clean-text-to-html subtitle
))</div
>)
210 (with-html-stream-output (:stream stream
)
211 (let ((*memoized-output-stream
* stream
)) (clean-html* html-body
))))
215 (post-headline-to-html post
))
216 (dolist (subcollection subcollections
)
217 (collection-to-html subcollection
(1+ heading-level
) used-anchors
)))
220 (dolist (subcollection subcollections
)
221 (collection-to-html subcollection heading-level used-anchors
)))))))
223 (defun sequence-to-html (sequence)
224 (labels ((contents-to-html (contents &key title subtitle number
)
225 (let ((html-body (cdr (assoc :html contents
))))
226 (when (or html-body title subtitle
)
227 <div class
="body-text sequence-text">
229 <h1 class
="sequence-chapter">(safe (format nil
"~@[~A. ~]~A" number
(clean-text-to-html title
:hyphenation nil
)))</h1
>)
231 <div class
="sequence-subtitle">(clean-text-to-html subtitle
)</div
>)
232 (with-html-stream-output (:stream stream
)
234 (let ((*memoized-output-stream
* stream
)) (clean-html* html-body
))))
236 (chapter-to-html (chapter)
237 (alist-bind ((title (or string null
))
238 (subtitle (or string null
))
239 (number (or fixnum null
))
244 (with-html-stream-output
245 (contents-to-html contents
:title title
:subtitle subtitle
:number number
)
247 (with-html-stream-output
249 (post-headline-to-html post
)))
252 (alist-bind ((sequence-id string
:--id
)
259 (multiple-value-bind (pretty-time js-time
) (pretty-time created-at
)
262 <h1 class
="post-title">(safe (clean-text-to-html title
:hyphenation nil
))</h1
>
263 <h1 class
="listing"><a href
=("/s/~A" sequence-id
)>(safe (clean-text-to-html title
:hyphenation nil
))</a
></h1
>)
264 <div class
="post-meta">
265 <a class
=("author~{ ~A~}" (list-cond ((logged-in-userid user-id
) "own-user-author")))
266 href
=("/users/~A" (get-user-slug user-id
))
268 (get-username user-id
)
270 <div class
="date" data-js-date
=js-time
>
272 (safe (pretty-time-js))
275 (with-html-stream-output
277 (contents-to-html contents
)
278 (dolist (chapter chapters
)
279 (chapter-to-html chapter
))))
282 (defun abort-response ()
283 (throw 'abort-response nil
))
285 (defun abort-response-if-unrecoverable (condition)
286 (when (html-output-stream-error-p condition
)
289 (defmacro with-error-html-block
(() &body body
)
290 "If an error occurs within BODY, write an HTML representation of the
291 signaled condition to *HTML-OUTPUT*."
292 `(block with-error-html-block
293 (handler-bind ((serious-condition (lambda (c)
294 (abort-response-if-unrecoverable c
)
296 (return-from with-error-html-block nil
))))
297 (log-conditions (progn ,@body
)))))
299 (defun make-comment-parent-hash-real (comments)
300 (let ((existing-comment-hash (make-hash-table :test
'equal
))
301 (hash (make-hash-table :test
'equal
)))
303 (if-let (id (cdr (assoc :--id c
)))
304 (setf (gethash id existing-comment-hash
) t
)))
306 (let* ((parent-id (cdr (assoc :parent-comment-id c
)))
307 (old (gethash parent-id hash
)))
308 (setf (gethash parent-id hash
) (cons c old
))
309 (when (and parent-id
(not (gethash parent-id existing-comment-hash
)))
310 (let ((placeholder (alist :--id parent-id
:parent-comment-id nil
:deleted t
)))
311 (setf (gethash parent-id existing-comment-hash
) t
312 (gethash nil hash
) (cons placeholder
(gethash nil hash
)))))))
313 (maphash (lambda (k old
)
314 (setf (gethash k hash
) (nreverse old
)))
317 ((count-children (parent)
318 (let ((children (gethash (cdr (assoc :--id parent
)) hash
)))
319 (+ (length children
) (apply #'+ (map 'list
#'count-children children
)))))
320 (add-child-counts (comment-list)
321 (loop for c in comment-list
322 as id
= (cdr (assoc :--id c
))
323 do
(setf (gethash id hash
) (add-child-counts (gethash id hash
)))
324 collecting
(cons (cons :child-count
(count-children c
)) c
))))
325 (setf (gethash nil hash
) (add-child-counts (gethash nil hash
))))
328 (defparameter *comment-parent-hash-cache
* (make-hash-table :test
'eq
332 (defun make-comment-parent-hash (comments)
333 (or (gethash comments
*comment-parent-hash-cache
*)
334 (setf (gethash comments
*comment-parent-hash-cache
*) (make-comment-parent-hash-real comments
))))
336 (defun comment-thread-to-html (out-stream emit-comment-item-fn
)
337 (format out-stream
"<ul class=\"comment-thread\">")
338 (funcall emit-comment-item-fn
)
339 (format out-stream
"</ul>"))
341 (defun comment-item-to-html (out-stream comment
&key extra-html-fn with-post-title level level-invert
)
342 (with-error-html-block ()
343 (let ((c-id (cdr (assoc :--id comment
)))
344 (user-id (cdr (assoc :user-id comment
))))
345 (format out-stream
"<li id=\"comment-~A\" class=\"comment-item~{ ~A~}\">"
348 (t (if (let ((is-odd (or (not level
) (evenp level
)))) ;inverted because level counts from 0
349 (if level-invert
(not is-odd
) is-odd
))
350 "depth-odd" "depth-even"))
351 ((and *current-ignore-hash
* (gethash user-id
*current-ignore-hash
*)) "ignored")))
353 (comment-to-html out-stream comment
:with-post-title with-post-title
)
354 (if extra-html-fn
(funcall extra-html-fn c-id
))
355 (format out-stream
"</li>")))))
357 (defun comment-tree-to-html (out-stream comment-hash
&key
(target nil
) (level (if target
1 0)) level-invert
)
358 (let ((comments (gethash target comment-hash
)))
360 (comment-thread-to-html out-stream
362 (loop for c in comments do
363 (comment-item-to-html out-stream c
365 :level-invert level-invert
366 :extra-html-fn
(lambda (c-id)
367 (if (and (= level
10) (gethash c-id comment-hash
))
368 (format out-stream
"<input type=\"checkbox\" id=\"expand-~A\"><label for=\"expand-~:*~A\" data-child-count=\"~A comment~:P\">Expand this thread</label>"
370 (cdr (assoc :child-count c
))))
371 (comment-tree-to-html out-stream comment-hash
:target c-id
:level
(1+ level
) :level-invert level-invert
)))))))))
373 (defun sort-items (items sort-by
)
374 (multiple-value-bind (sort-fn key-fn
)
376 ((:old
:new
) (values (if (eq sort-by
:old
)
377 (lambda (a b
) (ignore-errors (local-time:timestamp
< a b
)))
378 (lambda (a b
) (ignore-errors (local-time:timestamp
> a b
))))
379 (lambda (c) (ignore-errors (local-time:parse-timestring
(or (cdr (assoc :posted-at c
))
380 (cdr (assoc :created-at c
)))))))))
381 (sort items sort-fn
:key key-fn
)))
383 (defun comment-chrono-to-html (out-stream comments
)
384 (let ((comment-hash (make-comment-parent-hash comments
))
385 (comments (sort-items comments
:old
)))
386 (comment-thread-to-html out-stream
388 (loop for c in comments do
389 (let* ((c-id (cdr (assoc :--id c
)))
390 (new-c (acons :children
(gethash c-id comment-hash
) c
)))
391 (comment-item-to-html out-stream new-c
)))))))
393 (defun comment-post-interleave (list &key limit offset
(sort-by :date
))
394 (multiple-value-bind (sort-fn sort-key
)
396 (:date
(values #'local-time
:timestamp
> (lambda (x) (local-time:parse-timestring
(cdr (assoc :posted-at x
))))))
397 (:date-reverse
(values #'local-time
:timestamp
< (lambda (x) (local-time:parse-timestring
(cdr (assoc :posted-at x
))))))
398 (:score
(values #'> (lambda (x) (cdr (assoc :base-score x
))))))
399 (let ((sorted (sort list sort-fn
:key sort-key
)))
400 (loop for end
= (if (or limit offset
) (+ (or limit
0) (or offset
0)))
403 until
(and end
(>= count end
))
404 when
(or (not offset
) (>= count offset
))
407 (defun identify-item (x)
410 (if-let (typename (cdr (assoc :----typename x
)))
411 (find-symbol (string-upcase typename
) (find-package :keyword
))
415 ((assoc :comment-count x
)
419 (condition :condition
)))
421 (defun write-index-items-to-html (out-stream items
&key need-auth
(empty-message "No entries.") skip-section
)
424 (with-error-html-block ()
425 (ecase (identify-item x
)
429 (format out-stream
"<p>~A</p>" (cdr (assoc :message x
))))
431 (format out-stream
"<ul class=\"comment-thread\"><li class=\"comment-item depth-odd\">")
433 (conversation-message-to-html out-stream x
)
434 (format out-stream
"</li></ul>")))
436 (conversation-index-to-html out-stream x
))
438 (post-headline-to-html x
:need-auth
(or need-auth
(cdr (assoc :draft x
))) :skip-section skip-section
))
440 (comment-thread-to-html out-stream
441 (lambda () (comment-item-to-html out-stream x
:with-post-title t
))))
443 (sequence-to-html x
)))))
444 (format out-stream
"<div class=\"listing-message\">~A</div>" empty-message
)))
446 (defun write-index-items-to-rss (out-stream items
&key title need-auth
)
447 (let ((full-title (format nil
"~@[~A - ~]~A" title
(site-title *current-site
*)))
448 (items (firstn (sort-items items
:new
) 20)))
449 (xml-emitter:with-rss2
(out-stream :encoding
"UTF-8")
450 (xml-emitter:rss-channel-header full-title
(site-uri *current-site
*) :description full-title
)
451 (labels ((emit-item (item &key title link
(guid (cdr (assoc :--id item
))) (author (get-username (cdr (assoc :user-id item
))))
452 (date (pretty-time (cdr (assoc :posted-at item
)) :format local-time
:+rfc-1123-format
+)) body
)
453 (xml-emitter:rss-item
461 (ecase (identify-item item
)
463 (let ((author (get-username (cdr (assoc :user-id item
))))
464 (is-event (cdr (assoc :is-event item
))))
466 :title
(clean-text (format nil
"~A by ~A" (cdr (assoc :title item
)) author
))
468 :link
(generate-post-auth-link item
:absolute t
:need-auth need-auth
:item-subtype
(if is-event
"event" "post"))
469 :body
(clean-html (or (cdr (assoc :html-body
(get-post-body (cdr (assoc :--id item
)) :revalidate nil
))) "") :post-id
(cdr (assoc :--id item
))))))
471 (schema-bind (:comment item
(comment-id post-id user-id html-body
))
472 (when post-id
; XXX fixme
474 :title
(format nil
"Comment by ~A on ~A" (get-username user-id
) (get-post-title post-id
))
475 :link
(generate-item-link :post post-id
:comment-id comment-id
:absolute t
)
476 :body
(clean-html html-body
)))))))))))
478 (defun search-bar-to-html (out-stream)
479 (declare (special *current-search-query
*))
480 (let ((query (and (boundp '*current-search-query
*) (hunchentoot:escape-for-html
*current-search-query
*))))
481 (format out-stream
"<form action=\"/search\" class=\"nav-inner\"><input name=\"q\" type=\"search\" ~@[value=\"~A\"~] autocomplete=\"off\" accesskey=\"s\" title=\"Search [s]~@[ Tip: Paste a ~A URL here to jump to that page.~]\"><button>Search</button></form>" query
(main-site-title *current-site
*))))
483 (defun inbox-to-html (out-stream user-slug
&optional new-messages
)
484 (let* ((target-uri (format nil
"/users/~A?show=inbox" user-slug
))
485 (as-link (string= (hunchentoot:request-uri
*) target-uri
)))
486 (multiple-value-bind (nm-class nm-text
)
487 (if new-messages
(values "new-messages" "New messages") (values "no-messages" "Inbox"))
488 (format out-stream
"<~:[a href=\"~A\"~;span~*~] id=\"inbox-indicator\" class=\"~A\" accesskey=\"o\" title=\"~A~:[ [o]~;~]\">~A</a>"
489 as-link target-uri nm-class nm-text as-link nm-text
))))
491 (defmethod site-nav-bars ((site site
))
492 '((:secondary-bar
(("archive" "/archive" "Archive" :accesskey
"r")
493 ("about" "/about" "About" :accesskey
"t")
494 ("search" "/search" "Search" :html search-bar-to-html
)
496 (:primary-bar
(("home" "/" "Home" :description
"Latest frontpage posts" :accesskey
"h")
497 ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description
"Latest comments" :accesskey
"c")))))
499 (defmethod site-nav-bars ((site lesswrong-viewer-site
))
500 '((:secondary-bar
(("archive" "/archive" "Archive" :accesskey
"r")
501 ("sequences" "/library" "Sequences" :description
"Sequences" :accesskey
"q")
502 ("about" "/about" "About" :accesskey
"t")
503 ("search" "/search" "Search" :html search-bar-to-html
)
505 (:tertiary-bar
(("questions" "/index?view=questions" "Questions")
506 ("events" "/index?view=events" "Events")
507 ("shortform" "/shortform" "Shortform" :description
"Latest Shortform posts")
508 ("alignment-forum" "/index?view=alignment-forum" "Alignment Forum")
509 ("alignment-forum-comments" "/recentcomments?view=alignment-forum" "AF Comments")))
510 (:primary-bar
(("home" "/" "Home" :description
"Latest frontpage posts" :accesskey
"h")
511 ("featured" "/index?view=featured" "Featured" :description
"Latest featured posts" :accesskey
"f")
512 ("all" "/index?view=all" "All" :description
"Latest posts from all sections" :accesskey
"a")
513 ("tags" "/tags" "Tags" :description
"All tags" :accesskey
"v")
514 ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description
"Latest comments" :accesskey
"c")))))
516 (defmethod site-nav-bars ((site ea-forum-viewer-site
))
517 '((:secondary-bar
(("archive" "/archive" "Archive" :accesskey
"r")
518 ("about" "/about" "About" :accesskey
"t")
519 ("search" "/search" "Search" :html search-bar-to-html
)
521 (:primary-bar
(("home" "/" "Home" :description
"Latest frontpage posts" :accesskey
"h")
522 ("all" "/index?view=all" "All" :description
"Latest posts from all sections" :accesskey
"a")
523 ("tags" "/tags" "Wiki" :description
"Wiki pages and tags" :accesskey
"v")
524 ("shortform" "/shortform" "Shortform" :description
"Latest Shortform posts")
525 ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description
"Latest comments" :accesskey
"c")))))
527 (defmethod site-nav-bars ((site progress-forum-viewer-site
))
528 '((:secondary-bar
(("archive" "/archive" "Archive" :accesskey
"r")
529 ("about" "/about" "About" :accesskey
"t")
530 ("search" "/search" "Search" :html search-bar-to-html
)
532 (:tertiary-bar
(("questions" "/index?view=questions" "Questions")
533 ("events" "/index?view=events" "Events")
534 ("shortform" "/shortform" "Shortform" :description
"Latest Shortform posts")))
535 (:primary-bar
(("home" "/" "Home" :description
"Latest frontpage posts" :accesskey
"h")
536 ("featured" "/index?view=featured" "Featured" :description
"Latest featured posts" :accesskey
"f")
537 ("all" "/index?view=all" "All" :description
"Latest posts from all sections" :accesskey
"a")
538 ("tags" "/tags" "Tags" :description
"All tags" :accesskey
"v")
539 ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description
"Latest comments" :accesskey
"c")))))
541 (defun prepare-nav-bar (nav-bar current-uri
)
542 (list (first nav-bar
)
543 (map 'list
(lambda (item) (if (listp item
) item
(funcall item current-uri
)))
546 (defun nav-item-active (item current-uri
)
548 (destructuring-bind (id uri name
&key description html accesskey nofollow trailing-html override-uri
) item
549 (declare (ignore id name description html accesskey nofollow trailing-html
))
550 (string= (or override-uri uri
) current-uri
))))
552 (defun nav-bar-active (nav-bar current-uri
)
553 (some (lambda (x) (nav-item-active x current-uri
)) (second nav-bar
)))
555 (defun nav-bar-inner (out-stream items
&optional current-uri
)
556 (maplist (lambda (items)
557 (let ((item (first items
)))
558 (destructuring-bind (id uri name
&key description html accesskey nofollow trailing-html override-uri
) item
559 (declare (ignore override-uri
))
560 (let* ((item-active (nav-item-active item current-uri
))
561 (nav-class (format nil
"nav-item ~:[nav-inactive~;nav-current~]~:[~; nav-item-last-before-current~]"
562 item-active
(and (not item-active
) (nav-item-active (cadr items
) current-uri
)))))
563 (format out-stream
"<span id=\"nav-item-~A\" class=\"~A\" ~@[title=\"~A\"~]>"
564 id nav-class description
)
566 (funcall html out-stream
)
567 (link-if-not out-stream item-active uri
"nav-inner" name
:accesskey accesskey
:nofollow nofollow
))
569 (funcall trailing-html out-stream
))
570 (format out-stream
"</span>")))))
573 (defun nav-bar-outer (out-stream class nav-bar
&optional current-uri
)
574 (format out-stream
"<nav id=\"~A\" class=\"nav-bar~@[ ~A~]\">" (string-downcase (first nav-bar
)) class
)
575 (nav-bar-inner out-stream
(second nav-bar
) current-uri
)
576 (format out-stream
"</nav>"))
578 (defun nav-bar-to-html (out-stream class current-uri
)
579 (let* ((nav-bars (map 'list
(lambda (x) (prepare-nav-bar x current-uri
)) (site-nav-bars *current-site
*)))
580 (active-bar (or (find-if (lambda (x) (nav-bar-active x current-uri
)) nav-bars
) (car (last nav-bars
))))
581 (inactive-bars (remove active-bar nav-bars
)))
582 (dolist (bar inactive-bars
)
583 (nav-bar-outer out-stream
(format nil
"~@[~A ~]inactive-bar" class
) bar current-uri
))
584 (nav-bar-outer out-stream
(format nil
"~@[~A ~]active-bar" class
) active-bar current-uri
)))
586 (defun user-nav-item (&optional current-uri
)
588 `("login" "/login" "Read Only Mode" :html
,(lambda (out-stream)
589 (format out-stream
"<span class=\"nav-inner\" title=\"~A\">[Read Only Mode]</span>"
590 (typecase *read-only-mode
*
591 (string *read-only-mode
*)
592 (t *read-only-default-message
*)))))
593 (if-let (username (logged-in-username))
594 (let ((user-slug (encode-entities (logged-in-user-slug))))
595 `("login" ,(format nil
"/users/~A" user-slug
) ,(plump:encode-entities username
) :description
"User page" :accesskey
"u"
596 :trailing-html
,(lambda (out-stream) (inbox-to-html out-stream user-slug
))))
597 `("login" "/login" "Log In"
598 :html
,(lambda (out-stream)
599 (write-string "<form action='/login' id='login-button-form'><input type='hidden' name='return' value='" out-stream
)
600 (encode-entities current-uri out-stream
)
601 (write-string "'></form><button class='nav-inner' form='login-button-form' accesskey='u'>Log In</button>" out-stream
))))))
603 (defun sublevel-nav-to-html (options current
&key default
(base-uri (hunchentoot:request-uri
*)) (param-name "show") (remove-params '("offset")) extra-class
)
604 (declare (type (or null string
) extra-class
))
605 (let ((out-stream *html-output
*))
606 (format out-stream
"<nav class=\"sublevel-nav~@[ ~A~]\">" extra-class
)
607 (loop for item in options
608 do
(destructuring-bind (param-value &key
(text (string-capitalize param-value
)) description
) (if (atom item
) (list item
) item
)
609 (let* ((param-value (string-downcase param-value
))
610 (selected (string-equal current param-value
))
611 (class (if selected
"sublevel-item selected" "sublevel-item")))
612 (link-if-not out-stream selected
(apply #'replace-query-params base-uri param-name
(unless (string-equal param-value default
) param-value
)
613 (loop for x in remove-params nconc
(list x nil
)))
614 class text
:title description
))))
615 (format out-stream
"</nav>")))
617 (defmacro set-script-variables
(&rest clauses
)
618 (with-gensyms (out-stream name value
)
619 `(with-html-stream-output (:stream
,out-stream
)
620 ,.
(loop for clause in clauses
621 collect
(destructuring-bind (name-form value-form
) clause
622 `(let ((,name
,name-form
)
623 (,value
,value-form
))
624 (declare (dynamic-extent ,name
,value
))
625 (write-string ,name
,out-stream
)
626 (write-string "=" ,out-stream
)
627 (json:encode-json
,value
,out-stream
)
628 (write-string #.
(format nil
";~%") ,out-stream
)))))))
630 (defun html-body (out-stream fn
&key title description social-description current-uri content-class robots extra-head
)
631 (macrolet ((for-resource-type ((resource-type &rest args
) &body body
)
632 (with-gensyms (resource)
633 `(dolist (,resource page-resources
)
634 (when (eq (first ,resource
) ,resource-type
)
635 (destructuring-bind ,args
(rest ,resource
)
637 (with-html-stream-output
638 (let* ((session-token (hunchentoot:cookie-in
"session-token"))
639 (csrf-token (and session-token
(make-csrf-token session-token
)))
640 (hide-nav-bars (truthy-string-p (hunchentoot:get-parameter
"hide-nav-bars")))
642 (page-resources (nreverse *page-resources
*))
643 (site-domain (site-domain *current-site
*)))
644 (setf *page-resources
* nil
)
645 (write-string "<!DOCTYPE html><html lang=\"en-US\"><head>
646 <meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">
647 <meta name=\"HandheldFriendly\" content=\"True\" />"
649 (with-delimited-writer (out-stream delimit
:begin
"<script>" :end
"</script>")
652 (set-script-variables ("document.domain" site-domain
))) ; Requires origin-agent-cluster header, see below
655 (when (typep *current-site
* 'login-site
)
656 (set-script-variables
657 ("loggedInUserId" (or (logged-in-userid) ""))
658 ("loggedInUserDisplayName" (or (logged-in-username) ""))
659 ("loggedInUserSlug" (or (logged-in-user-slug) ""))))
660 (set-script-variables
661 ("applicationServerKey" (get-vapid-public-key))
662 ("GW" (alist "useFancyFeatures" (not (typep *current-site
* 'arbital-site
))
663 "secureCookies" (to-boolean (site-secure *current-site
*))
664 "csrfToken" csrf-token
665 "assets" (alist "popup.svg" (generate-versioned-link "/assets/popup.svg"))
666 "sites" (if site-domain
667 (loop for site in
*sites
*
668 when
(let ((sd (site-domain site
))) (and sd
(string-equal sd site-domain
)))
669 collect
(cons (site-host site
) t
))
670 (alist (site-host *current-site
*) t
)))))
671 (for-resource-type (:inline-script script-text
)
672 (write-string ";" out-stream
)
673 (write-string script-text out-stream
))))
675 (funcall lw2.resources
::*script-tags
* out-stream
)
676 (for-resource-type (:script uri
)
677 (format out-stream
"<script src=\"~A\"></script>" uri
))
678 (funcall lw2.resources
::*async-script-tags
* out-stream
)
679 (for-resource-type (:async-script uri
)
680 (format out-stream
"<script src=\"~A\" async></script>" uri
)))
681 (funcall lw2.resources
::*style-tags
* out-stream
)
682 (for-resource-type (:stylesheet uri
&key media class
)
683 (format out-stream
"<link rel=\"stylesheet\" href=\"~A\"~@[ media=\"~A\"~]~@[ class=\"~A\"~]>" uri media class
))
684 (generate-fonts-html-headers (site-fonts-source *current-site
*))
685 (format out-stream
"<link rel=\"shortcut icon\" href=\"~A\">"
686 (generate-versioned-link "/assets/favicon.ico"))
687 (format out-stream
"<title>~@[~A - ~]~A</title>~@[<meta name=\"description\" content=\"~A\">~]~@[<meta name=\"robots\" content=\"~A\">~]"
688 (if title
(encode-entities title
))
689 (site-title *current-site
*)
694 <meta property
="og:title" content
=title
>)
695 (when social-description
696 <meta property
="og:description" content
=social-description
>
697 <meta property
="og:type" content
="article">))
698 (with-delimited-writer (out-stream delimit
:begin
"<style>" :between
#.
(format nil
"~%") :end
"</style>")
699 (unless (and (typep *current-site
* 'login-site
) (logged-in-userid))
701 (write-string "button.vote { display: none }" out-stream
))
702 (when *memoized-output-without-hyphens
*
703 ;; The browser has been detected as having bugs related to soft-hyphen characters.
704 ;; But there is some hope that it could still do hyphenation by itself.
706 (write-string ".body-text { hyphens: auto; -ms-hyphens: auto; -webkit-hyphens: auto; }" out-stream
)))
708 (format out-stream
"<base target='_top'>"))
709 (when extra-head
(funcall extra-head
))
710 (format out-stream
"</head>")
713 (format out-stream
"<body class=\"theme-~A\"><div id=\"content\"~@[ class=\"~{~A~^ ~}\"~]>"
714 (let ((theme (hunchentoot:cookie-in
"theme")))
715 (if (and theme
(> (length theme
) 0))
718 (list-cond (content-class content-class
)
719 (hide-nav-bars "no-nav-bars")
720 (preview "preview")))
721 (unless (or hide-nav-bars preview
)
722 (nav-bar-to-html out-stream
"nav-bar-top" (or current-uri
(replace-query-params (hunchentoot:request-uri
*) "offset" nil
"sort" nil
)))
723 (when (and (typep *current-site
* 'login-site
) (logged-in-userid))
724 (call-with-server-data 'process-user-status
"/current-user-status")))
725 (activate-client-trigger "navBarLoaded")
727 (format out-stream
"</div></body></html>"))))))
729 (defun replace-query-params (uri &rest params
)
730 (let* ((quri (quri:uri uri
))
731 (old-params (quri:uri-query-params quri
))
732 (new-params (loop with out
= old-params
733 for
(param value
) on params by
#'cddr
735 (if-let (old-cons (assoc param out
:test
#'equal
))
736 (setf (cdr old-cons
) value
)
737 (setf out
(nconc out
(list (cons param value
)))))
738 (setf out
(remove-if (lambda (x) (equal (car x
) param
)) out
)))
739 finally
(return out
))))
741 (setf (quri:uri-query-params quri
) new-params
)
742 (setf (quri:uri-query quri
) nil
))
743 (quri:render-uri quri
)))
745 (defun pagination-nav-bars (&key offset total with-next
(items-per-page (user-pref :items-per-page
)))
747 (lambda (out-stream fn
)
748 (declare (ignore out-stream
))
750 (lambda (out-stream fn
)
751 (labels ((pages-to-end (n) (< (+ offset
(* items-per-page n
)) total
)))
752 (let* ((with-next (if total
(pages-to-end 1) with-next
))
753 (next (if (and offset with-next
) (+ offset items-per-page
)))
754 (prev (if (and offset
(>= offset items-per-page
)) (- offset items-per-page
)))
755 (request-uri (hunchentoot:request-uri
*))
756 (first-uri (if (and prev
(> prev
0)) (replace-query-params request-uri
"offset" nil
)))
757 (prev-uri (if prev
(replace-query-params request-uri
"offset" (if (= prev
0) nil prev
))))
758 (next-uri (if next
(replace-query-params request-uri
"offset" next
)))
759 (last-uri (if (and total offset
(pages-to-end 2))
760 (replace-query-params request-uri
"offset" (- total
(mod (- total
1) items-per-page
) 1)))))
761 (if (or next prev last-uri
)
762 (labels ((write-item (uri class title accesskey
)
763 (format out-stream
"<a href=\"~A\" class=\"button nav-item-~A~:[ disabled~;~]\" title=\"~A [~A]\" accesskey=\"~A\"></a>"
764 (or uri
"#") class uri title accesskey accesskey
)))
765 (format out-stream
"<nav id='top-nav-bar'>")
766 (write-item first-uri
"first" "First page" "\\")
767 (write-item prev-uri
"prev" "Previous page" "[")
768 (format out-stream
"<span class='page-number'><span class='page-number-label'>Page</span> ~A</span>" (+ 1 (/ (or offset
0) items-per-page
)))
769 (write-item next-uri
"next" "Next page" "]")
770 (write-item last-uri
"last" "Last page" "/")
771 (format out-stream
"</nav>")))
773 (nav-bar-outer out-stream nil
(list :bottom-bar
775 (first-uri `("first" ,first-uri
"Back to first"))
776 (prev-uri `("prev" ,prev-uri
"Previous" :nofollow t
))
777 (t `("top" "#top" "Back to top"))
778 (next-uri `("next" ,next-uri
"Next" :nofollow t
))
779 (last-uri `("last" ,last-uri
"Last" :nofollow t
)))))
780 (format out-stream
"<script>document.querySelectorAll('#bottom-bar').forEach(bb => { bb.classList.add('decorative'); });</script>"))))))
782 (defun decode-json-as-hash-table (json-source)
783 (let (current-hash-table current-key
)
784 (declare (special current-hash-table current-key
))
785 (json:bind-custom-vars
786 (:beginning-of-object
(lambda () (setf current-hash-table
(make-hash-table :test
'equal
)))
787 :object-key
(lambda (x) (setf current-key x
))
788 :object-value
(lambda (x) (setf (gethash current-key current-hash-table
) x
))
789 :end-of-object
(lambda () current-hash-table
)
790 :aggregate-scope
'(current-hash-table current-key
))
791 (json:decode-json-from-source json-source
))))
793 (defun get-ignore-hash (&optional
(user-id (logged-in-userid)))
794 (if-let (ignore-json (and user-id
(cache-get "user-ignore-list" user-id
)))
795 (decode-json-as-hash-table ignore-json
)
796 (make-hash-table :test
'equal
)))
798 (defmacro with-outputs
((out-stream) &body body
)
799 (with-gensyms (stream-sym)
800 (let ((out-body (map 'list
(lambda (x) `(princ ,x
,stream-sym
)) body
)))
801 `(let ((,stream-sym
,out-stream
))
804 (defun call-with-emit-page (out-stream fn
&key title description social-description current-uri content-class
(return-code 200) robots
(pagination (pagination-nav-bars)) top-nav extra-head
)
805 (declare (ignore return-code
))
808 (html-body out-stream
810 (when top-nav
(funcall top-nav
))
811 (funcall pagination out-stream fn
))
812 :title title
:description description
:social-description social-description
:current-uri current-uri
:content-class content-class
:robots robots
:extra-head extra-head
))))
814 (defun set-cookie (key value
&key
(max-age (- (expt 2 31) 1)) (path "/"))
815 (hunchentoot:set-cookie key
:value value
:path path
:max-age max-age
:secure
(site-secure *current-site
*)))
817 (defun set-default-headers (return-code)
818 (setf (hunchentoot:content-type
*) "text/html; charset=utf-8"
819 (hunchentoot:return-code
*) return-code
820 (hunchentoot:header-out
:link
) (let ((output
821 (with-output-to-string (stream)
822 (with-delimited-writer (stream delimit
:between
",")
823 (funcall lw2.resources
::*link-header
* stream delimit
)))))
824 (when (> (length output
) 0)
826 (unless lw2.resources
::*push-option
* (set-cookie "push" "t" :max-age
(* 4 60 60))))
828 (defun user-pref (key)
829 (or (cdr (assoc key
*current-prefs
*))
830 (cdr (assoc key
*default-prefs
*))))
832 (defun set-user-pref (key value
)
833 (assert (boundp 'hunchentoot
:*reply
*))
835 (setf *current-prefs
* (remove-duplicates (acons key value
*current-prefs
*) :key
#'car
:from-end t
))
836 (setf *current-prefs
* (remove key
*current-prefs
* :key
#'car
)))
837 (set-cookie "prefs" (quri:url-encode
(json:encode-json-to-string
*current-prefs
*))))
839 (defmacro emit-page
((out-stream &rest args
&key
(return-code 200) &allow-other-keys
) &body body
)
840 (once-only (return-code)
842 (set-default-headers ,return-code
)
843 (with-response-stream (,out-stream
)
844 (dynamic-flet ((fn () ,@body
))
845 (call-with-emit-page ,out-stream
849 (defmethod call-with-backend-context ((backend backend-token-login
) (request (eql t
)) fn
)
850 (let ((*current-auth-status
* (safe-decode-json (hunchentoot:cookie-in
"lw2-status"))))
851 (multiple-value-bind (*current-auth-token
* *current-userid
* *current-username
*)
852 (let* ((auth-token (hunchentoot:cookie-in
"lw2-auth-token"))
853 (expires (cdr (assoc :expires
*current-auth-status
*))))
854 (when (and (nonempty-string auth-token
)
855 (not *read-only-mode
*)
857 (and (integerp expires
) (<= (get-unix-time) (- expires
(* 60 60 24))))))
858 (with-cache-readonly-transaction
861 (cache-get "auth-token-to-userid" auth-token
)
862 (cache-get "auth-token-to-username" auth-token
)))))
863 (let ((*current-user-slug
* (and *current-userid
* (get-user-slug *current-userid
*)))
864 (*enable-rate-limit
* (if *current-userid
* nil
*enable-rate-limit
*)))
867 (defmethod call-with-site-context ((site ignore-list-site
) (request (eql t
)) fn
)
871 (let ((*current-ignore-hash
* (get-ignore-hash)))
874 (defun call-with-error-page (fn)
875 (with-response-context ()
876 (let* ((*current-prefs
* (safe-decode-json (hunchentoot:cookie-in
"prefs")))
877 (*preview
* (string-equal (hunchentoot:get-parameter
"format") "preview")))
878 (multiple-value-bind (*revalidate-default
* *force-revalidate-default
*)
879 (cond ((ppcre:scan
"(?:^|,?)\\s*(?:no-cache|max-age=0)(?:$|,)" (hunchentoot:header-in
* :cache-control
))
885 (when (not *revalidate-default
*)
886 (setf (hunchentoot:header-out
:cache-control
) (format nil
"public, max-age=~A" (* 5 60))))
887 (when (site-domain *current-site
*)
888 (setf (hunchentoot:header-out
:origin-agent-cluster
) "?0")) ; Allow document.domain in Chrome: https://developer.chrome.com/blog/immutable-document-domain/
889 (let ((*memoized-output-without-hyphens
*
890 ;; Soft hyphen characters mess up middle-click paste and screen readers, so try to identify whether they are necessary.
891 ;; See https://caniuse.com/?search=hyphens
892 (if-let ((ua (hunchentoot:header-in
* :user-agent
)))
895 (declare (regex-groups-min 1))
896 (or (> (parse-integer (reg 0)) 87)
897 (ppcre:scan
"Macintosh|Android" ua
)))
899 (declare (regex-groups-min 1))
900 (> 19 (parse-integer (reg 0))))
904 (catch 'abort-response
906 ((fatal-error (lambda (condition)
907 (abort-response-if-unrecoverable condition
)
908 (let ((error-html (with-output-to-string (*html-output
*) (error-to-html condition
))))
909 (emit-page (out-stream :title
"Error" :return-code
(condition-http-return-code condition
) :content-class
"error-page")
910 (write-string error-html out-stream
)
911 (when (eq (hunchentoot:request-method
*) :post
)
912 <form method
="post" class
="error-retry-form">
913 (loop for
(key . value
) in
(hunchentoot:post-parameters
*)
914 do
<input type
="hidden" name
=key value
=value
>)
915 <input type
="submit" value
="Retry">
917 (return-from call-with-error-page
)))))
919 (if (or (eq (hunchentoot:request-method
*) :post
)
920 (not (and (boundp '*test-acceptor
*) (boundp '*hunchentoot-taskmaster
*)))) ; TODO fix this hack
922 (sb-sys:with-deadline
(:seconds
(expt 1.3
923 (min (round (log 30 1.3))
924 (- (hunchentoot:taskmaster-max-thread-count
(symbol-value '*hunchentoot-taskmaster
*))
925 (hunchentoot:acceptor-requests-in-progress
(symbol-value '*test-acceptor
*))))))
926 (funcall fn
))))))))))))
928 (defmacro with-error-page
(&body body
)
929 `(dynamic-flet ((fn () ,@body
)) (call-with-error-page #'fn
)))
931 (defun output-form (out-stream method action id heading csrf-token fields button-label
&key textarea end-html
)
932 (format out-stream
"<form method=\"~A\" action=\"~A\" id=\"~A\"><h1>~A</h1>" method action id heading
)
933 (loop for
(id label type . params
) in fields
934 do
(format out-stream
"<label for=\"~A\">~A:</label>" id label
)
936 ((string= type
"select")
937 (destructuring-bind (option-list &optional default
) params
938 (format out-stream
"<select name=\"~A\">" id
)
939 (loop for
(value label
) in option-list
940 do
(format out-stream
"<option value=\"~A\"~:[~; selected~]>~A</option>" value
(string= default value
) label
))
941 (format out-stream
"</select>")))
943 (destructuring-bind (&optional
(autocomplete "off") default
) params
944 (format out-stream
"<input type=\"~A\" name=\"~A\" autocomplete=\"~A\"~@[ value=\"~A\"~]>" type id autocomplete
(and default
(encode-entities default
))))))
945 do
(format out-stream
""))
947 (destructuring-bind (ta-name ta-contents
) textarea
948 (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
))))
949 (format out-stream
"<input type=\"hidden\" name=\"csrf-token\" value=\"~A\"><input type=\"submit\" value=\"~A\">~@[~A~]</form>"
950 csrf-token button-label end-html
))
952 (defun page-toolbar-to-html (&key title new-post new-conversation logout
(rss t
) ignore enable-push-notifications
)
954 (let ((out-stream *html-output
*)
955 (liu (logged-in-userid)))
956 (format out-stream
"<div class=\"page-toolbar~@[ hide-until-init~]\">" enable-push-notifications
)
958 (format out-stream
"<form method=\"post\" action=\"/logout\"><input type=\"hidden\" name=\"csrf-token\" value=\"~A\"><button class=\"logout-button button\" name=\"logout\">Log out</button></form>"
962 (when enable-push-notifications
963 (format out-stream
"<script>document.currentScript.outerHTML='<button id=\"enable-push-notifications\" class=\"button\" style=\"display: none\" data-enabled=\"~:[~;true~]\">~:*~:[En~;Dis~]able push notifications</button>'</script>"
964 (find-subscription *current-auth-token
*)))
965 (when (and new-conversation liu
)
966 (multiple-value-bind (text to
)
967 (typecase new-conversation
(string (values "Send private message" new-conversation
)) (t "New conversation"))
968 (format out-stream
"<a class=\"new-private-message button\" href=\"/conversation~@[?to=~A~]\">~A</a>"
970 (when (and new-post liu
)
971 (format out-stream
"<a class=\"new-post button\" href=\"/edit-post~@[?section=~A~]\" accesskey=\"n\" title=\"Create new post [n]\">New post</a>"
972 (typecase new-post
(string new-post
) (t nil
))))
973 (when (and title rss
)
974 (format out-stream
"<a class=\"rss\" rel=\"alternate\" type=\"application/rss+xml\" title=\"~A RSS feed\" href=\"~A\">RSS</a>"
975 title
(replace-query-params (hunchentoot:request-uri
*) "offset" nil
"format" "rss")))
976 (format out-stream
"</div>"))))
978 (defun view-items-index (items &key section title current-uri hide-title need-auth extra-head
(pagination (pagination-nav-bars)) (top-nav (lambda () (page-toolbar-to-html :title title
))) (content-class "index-page") alternate-html
)
979 (alexandria:switch
((hunchentoot:get-parameter
"format") :test
#'string
=)
981 (setf (hunchentoot:content-type
*) "application/rss+xml; charset=utf-8")
982 (with-response-stream (out-stream)
983 (write-index-items-to-rss out-stream items
:title title
)))
985 (emit-page (out-stream :title
(if hide-title nil title
) :description
(site-description *current-site
*) :content-class content-class
986 :current-uri current-uri
:robots
(if (hunchentoot:get-parameter
:offset
) "noindex, nofollow")
987 :pagination pagination
:top-nav top-nav
:extra-head extra-head
)
989 (funcall alternate-html
)
990 (write-index-items-to-html out-stream items
992 :skip-section section
))))))
994 (defun link-if-not (stream linkp url class text
&key accesskey nofollow title
)
995 (declare (dynamic-extent linkp url text
))
997 (format stream
"<a href=\"~A\" class=\"~A\"~@[ accesskey=\"~A\"~]~:[~; rel=\"nofollow\"~]~@[ title=\"~A\"~]>~A</a>" url class accesskey nofollow title text
)
998 (format stream
"<span class=\"~A\"~@[ title=\"~A\"~]>~A</span>" class title text
)))
1000 (defgeneric main-site-link
(site item-type item-designator
&key
)
1001 (:method
((site lw2-frontend-site
) (item-type (eql :post
)) (post-id string
) &key slug comment-id direct-comment-link
)
1003 (format nil
"/posts/~A/~A~[~;#~A~;?commentId=~A~]" post-id slug
(if comment-id
(if direct-comment-link
2 1) 0) comment-id
)
1004 (main-site-uri *current-site
*)))
1005 (:method
((site lw2-frontend-site
) (item-type (eql :tag
)) (slug string
) &key comment-id direct-comment-link
)
1006 (when (not (and comment-id direct-comment-link
))
1008 (format nil
"/tag/~A~@[/discussion#~A~]" slug comment-id
)
1009 (main-site-uri *current-site
*)))))
1011 (defun postprocess-markdown (markdown)
1012 (if (typep *current-site
* 'alternate-frontend-site
)
1014 ((concatenate 'string
(regex-replace-all "\\." (site-uri *current-site
*) "\\.") "posts/([^/ ]{17})/([^/# ]*)(?:(#comment-|/comment/|/answer/)([^/ ]{17}))?")
1016 (main-site-link *current-site
*
1017 :post
(reg 0) :slug
(reg 1) :comment-id
(reg 3)
1018 :direct-comment-link
(and (reg 3) (reg 2) (string= "/" (reg 2) :end2
1))))
1021 (defun redirect (uri &key
(type :see-other
) preserve-query
)
1022 (setf (hunchentoot:return-code
*) (ecase type
(:see-other
303) (:permanent
301))
1023 (hunchentoot:header-out
"Location") (if-let ((query (and preserve-query
(hunchentoot:query-string
*))))
1024 (quri:render-uri
(quri:make-uri
:defaults uri
:query query
))
1027 (defun main-site-redirect (uri &key
(type :see-other
))
1028 (redirect (merge-uris uri
(main-site-uri *current-site
*)) :type type
))
1030 (defmacro request-method
(&body method-clauses
)
1031 (with-gensyms (request-method)
1032 `(let ((,request-method
(hunchentoot:request-method
*)))
1034 ,.
(loop for method-body in method-clauses
1035 collect
(destructuring-bind (method args
&body inner-body
) method-body
1036 `(,(if (eq method
:get
) `(member ,request-method
'(:get
:head
)) `(eq ,request-method
,method
))
1037 ,(make-binding-form (mapcar (lambda (x) (append (ensure-list x
) `(:request-type
,method
))) args
)
1040 (defmacro define-page
(name path-specifier additional-vars
&body body
)
1041 (labels ((make-lambda (args)
1043 collect
(if (atom a
) a
(first a
)))))
1044 (multiple-value-bind (path-specifier-form path-bindings-wrapper specifier-vars
)
1045 (if (stringp path-specifier
)
1046 (values path-specifier
#'identity
)
1047 (destructuring-bind (specifier-type specifier-body
&rest specifier-args
) path-specifier
1048 (ecase specifier-type
1050 (values `(lambda (r) (funcall ,specifier-body
(hunchentoot:request-uri r
)))
1052 (lambda (body) `(ignorable-multiple-value-bind ,(make-lambda specifier-args
) (funcall ,specifier-body
(hunchentoot:request-uri
*)) ,body
))
1056 (let ((fn `(lambda (r) (ppcre:scan-to-strings
,specifier-body
(hunchentoot:request-uri r
)))))
1059 (with-gensyms (result-vector)
1060 `(let ((,result-vector
(nth-value 1 (funcall ,fn hunchentoot
:*request
*))))
1061 (declare (type simple-vector
,result-vector
)
1062 (ignorable ,result-vector
))
1064 ,(loop for v in
(make-lambda specifier-args
) as x from
0 collecting
`(,v
(if (> (length ,result-vector
) ,x
) (aref ,result-vector
,x
))))
1066 specifier-args
))))))
1067 `(hunchentoot:define-easy-handler
(,name
:uri
,path-specifier-form
) ()
1070 ,(funcall path-bindings-wrapper
1071 (make-binding-form (append (mapcar (lambda (x) (append (ensure-list x
) '(:passthrough t
))) specifier-vars
) additional-vars
)
1074 (define-component sort-widget
(&key
(sort-options '((:new
:description
"Sort by date posted")
1075 (:hot
:description
"Sort by time-weighted score")
1076 (:active
:description
"Sort by date posted or last comment")
1077 (:old
:description
"Sort by date posted, oldest first")))
1078 (pref :default-sort
) (param-name "sort") (html-class "sort"))
1079 (:http-args
((sort :real-name param-name
:member
(mapcar (lambda (x) (if (listp x
) (first x
) x
)) sort-options
))
1080 (sortedby :real-name
"sortedBy" :type string
)
1081 &without-csrf-check
))
1086 (let ((sort-string (if sort
(string-downcase sort
))))
1088 (set-user-pref :default-sort sort-string
))
1090 (sublevel-nav-to-html sort-options
1092 :param-name param-name
1093 :extra-class html-class
))
1094 (or sort-string
(user-pref pref
)))))
1096 (defun handle-last-modified (last-modified)
1098 (let ((last-modified (max last-modified
(load-time-value (get-universal-time)))))
1099 (setf (hunchentoot:header-out
:last-modified
) (hunchentoot:rfc-1123-date last-modified
)
1100 (hunchentoot:header-out
:vary
) "cookie")
1101 (hunchentoot:handle-if-modified-since last-modified
))))
1103 (define-component view-index
()
1104 (:http-args
((view :member
'(:all
:new
:frontpage
:featured
:alignment-forum
:questions
:nominations
:reviews
:events
) :default
:frontpage
)
1106 (offset :type fixnum
)
1107 (limit :type fixnum
:default
(user-pref :items-per-page
))
1108 (karma-threshold :type fixnum
)
1109 &without-csrf-check
))
1110 (when (eq view
:new
) (redirect (replace-query-params (hunchentoot:request-uri
*) "view" "all" "all" nil
) :type
:permanent
) (return))
1111 (component-value-bind ((sort-string sort-widget
))
1112 (multiple-value-bind (posts total last-modified
)
1113 (get-posts-index :view
(string-downcase view
) :before before
:after after
:offset offset
:limit
(1+ limit
) :sort sort-string
:karma-threshold karma-threshold
)
1114 (handle-last-modified last-modified
)
1115 (let ((page-title (format nil
"~@(~A posts~)" view
)))
1117 (view-items-index (firstn posts limit
)
1118 :section view
:title page-title
:hide-title
(eq view
:frontpage
)
1119 :pagination
(pagination-nav-bars :offset
(or offset
0) :total total
:with-next
(and (not total
) (> (length posts
) limit
)))
1120 :content-class
(format nil
"index-page ~(~A~)-index-page" view
)
1122 (page-toolbar-to-html :title page-title
1123 :new-post
(if (eq view
:meta
) "meta" t
))
1124 (funcall sort-widget
))))))))
1126 (defmacro route-component
(name lambda-list
&rest args
)
1127 `(lambda ,lambda-list
1129 (component-value-bind ((() (,name
,@args
)))
1131 (funcall ,name
))))))
1133 (defmacro define-component-routes
(site-class &rest clauses
)
1136 (for clause in clauses
)
1137 (destructuring-bind (name (route-class &rest route-args
) route-bindings
(component-name &rest component-args
)) clause
1138 (collect `(define-route ',site-class
',route-class
1139 :name
',name
,@route-args
1140 :handler
(route-component ,component-name
,route-bindings
,@component-args
)))))))
1142 (define-component-routes forum-site
1143 (view-root (standard-route :uri
"/") () (view-index))
1144 (view-index (standard-route :uri
"/index") () (view-index)))
1146 (hunchentoot:define-easy-handler
1149 (declare (ignore req
))
1150 (with-site-context ((let ((host (or (hunchentoot:header-in
* :x-forwarded-host
) (hunchentoot:header-in
* :host
))))
1151 (or (find-site host
)
1152 (error "Unknown site: ~A" host
))))
1153 (call-route-handler *current-site
* (hunchentoot:script-name
*)))))
1156 (define-page view-post
"/post" ((id :required t
))
1157 (redirect (generate-item-link :post id
) :type
:permanent
))
1159 (define-page view-post-lw1-link
(:function
#'match-lw1-link
) ()
1160 (redirect (convert-lw1-link (hunchentoot:script-name
*)) :preserve-query t
:type
:permanent
))
1162 (define-page view-post-ea1-link
(:function
#'match-ea1-link
) ()
1163 (redirect (convert-ea1-link (hunchentoot:script-name
*)) :preserve-query t
:type
:permanent
))
1165 (define-page view-post-lw2-slug-link
(:function
#'match-lw2-slug-link
) ()
1166 (redirect (convert-lw2-slug-link (hunchentoot:request-uri
*)) :type
:see-other
))
1168 (define-page view-post-lw2-sequence-link
(:function
#'match-lw2-sequence-link
) ()
1169 (redirect (convert-lw2-sequence-link (hunchentoot:request-uri
*)) :type
:see-other
))
1171 (define-page view-feed
"/feed" ()
1172 (redirect "/?format=rss" :type
:permanent
))
1174 (define-page view-allposts
"/allPosts" ()
1175 (redirect (format nil
"/index~@[?~A~]" (hunchentoot:query-string
*)) :type
:see-other
))
1177 (define-page view-nominations
"/nominations" ()
1178 (redirect "/index?view=nominations" :type
:see-other
))
1180 (define-page view-reviews
"/reviews" ()
1181 (redirect "/index?view=reviews" :type
:see-other
))
1183 (define-page view-review-voting
"/reviewVoting" ()
1184 (redirect "https://www.lesswrong.com/reviewVoting" :type
:see-other
))
1186 (define-page view-coronavirus-link-database
"/coronavirus-link-database" ()
1187 (redirect "https://www.lesswrong.com/coronavirus-link-database" :type
:see-other
))
1189 (defun post-comment (&key need-auth
((:post-id post-id-real
)) ((:tag-id tag-id-real
)) shortform
)
1191 (:post
(text answer nomination nomination-review af post-id tag-id parent-answer-id parent-comment-id edit-comment-id retract-comment-id unretract-comment-id delete-comment-id
)
1192 (let ((lw2-auth-token *current-auth-token
*))
1193 (assert lw2-auth-token
)
1194 (let* ((post-id (or post-id-real post-id
))
1195 (tag-id (or tag-id-real tag-id
))
1196 (question (when post-id
(cdr (assoc :question
(get-post-body post-id
:auth-token lw2-auth-token
)))))
1202 (t :body
(postprocess-markdown text
))
1203 ((and post-id
(not (or edit-comment-id
(and shortform
(not parent-comment-id
))))) :post-id post-id
)
1204 ((and tag-id
(not edit-comment-id
)) :tag-id tag-id
)
1205 (parent-comment-id :parent-comment-id parent-comment-id
)
1207 (nomination :nominated-for-review
"2020")
1208 (nomination-review :reviewing-for-review
"2020")
1209 (parent-answer-id :parent-answer-id parent-answer-id
)
1211 ((and shortform
(not parent-comment-id
)) :shortform t
))))
1213 (do-lw2-comment-edit lw2-auth-token edit-comment-id comment-data
)
1214 (do-lw2-comment lw2-auth-token comment-data
))))
1216 (do-lw2-comment-edit lw2-auth-token retract-comment-id
'((:retracted . t
))))
1217 (unretract-comment-id
1218 (do-lw2-comment-edit lw2-auth-token unretract-comment-id
'((:retracted .
:false
))))
1220 (do-lw2-comment-remove lw2-auth-token delete-comment-id
:reason
"Comment deleted by its author.")
1224 (get-post-comments post-id
:force-revalidate t
)
1226 (get-post-answers post-id
:force-revalidate t
))))
1228 (alist-bind ((new-comment-id simple-string
:--id
)
1229 (new-comment-html simple-string
:html-body
))
1231 (mark-comment-replied (alist* :parent-comment-id parent-comment-id
:user-id
*current-userid
* new-comment-result
))
1232 (setf (markdown-source :comment new-comment-id new-comment-html
) text
)
1233 (redirect (merge-uris (quri:make-uri
:fragment
(format nil
"comment-~A" new-comment-id
)
1234 :query
(list-cond (need-auth "need-auth" "y")))
1235 (hunchentoot:request-uri
*))))))))))
1237 (defun output-comments (out-stream id comments target
&key overcomingbias-sort preview chrono replies-open
)
1238 (labels ((output-comments-inner ()
1239 (with-error-html-block ()
1241 (comment-thread-to-html out-stream
1243 (comment-item-to-html
1246 :level-invert preview
1247 :extra-html-fn
(lambda (c-id)
1248 (let ((*comment-individual-link
* nil
))
1249 (comment-tree-to-html out-stream
(make-comment-parent-hash comments
)
1251 :level-invert preview
))))))
1253 (progn #|
<div class
="comments-empty-message">(safe (pretty-number (length comments
) id
))</div
>|
#
1255 (comment-chrono-to-html out-stream comments
)
1256 (let ((parent-hash (make-comment-parent-hash comments
)))
1257 (when overcomingbias-sort
1258 (setf (gethash nil parent-hash
)
1259 (sort-items (gethash nil parent-hash
) :old
)))
1260 (comment-tree-to-html out-stream parent-hash
))))
1261 <div class
="comments-empty-message">("No ~As." id
)</div
>)))))
1263 (output-comments-inner)
1264 (progn (format out-stream
"<div id=\"~As\" class=\"comments~:[~; replies-open~]\">" id
(and *enable-voting
* replies-open
))
1266 <script
>initializeCommentControls\
(\
)</script
>)
1267 (output-comments-inner)
1268 (format out-stream
"</div>")))))
1270 (define-json-endpoint (view-karma-vote-post forum-site
"/karma-vote/post")
1271 (let ((auth-token *current-auth-token
*))
1274 (hash-cond (make-hash-table)
1275 (post-id "Post" (sethash (make-hash-table) post-id
(get-post-vote post-id auth-token
)))
1276 (post-id "Comment" (get-post-comments-votes post-id auth-token
))
1277 (post-id "Tag" (get-post-tag-votes post-id auth-token
)))))))
1279 (define-page view-post-lw2-link
(:function
#'match-lw2-link post-id comment-id
* comment-link-type post-type
)
1282 (show-comments :real-name
"comments" :type boolean
:default t
)
1283 (format :type string
))
1286 (when (hunchentoot:get-parameter
"commentId")
1287 (redirect (format nil
"~A/comment/~A" (generate-item-link :post post-id
) comment-id
))
1289 (let* ((lw2-auth-token *current-auth-token
*)
1290 (preview (string-equal format
"preview"))
1291 (show-comments (and (not preview
) show-comments
))
1292 (*enable-voting
* (not (null (logged-in-userid)))))
1293 (multiple-value-bind (post title condition
)
1294 (handler-case (nth-value 0 (get-post-body post-id
:auth-token
(and need-auth lw2-auth-token
)))
1295 (serious-condition (c)
1296 (setf *enable-voting
* nil
)
1297 (values nil
"[missing post]" c
))
1299 (values post
(cdr (assoc :title post
)) nil
)))
1300 (let* ((is-event (cdr (assoc :is-event post
)))
1301 (correct-subtype (if is-event
"event" "post")))
1302 (when (string/= post-type correct-subtype
)
1303 (redirect (generate-item-link :post post
:comment-id comment-id
:item-subtype correct-subtype
))
1305 (labels ((extra-head ()
1306 (when-let (canonical-source (or (and (not comment-id
)
1307 (cdr (assoc :canonical-source post
)))
1308 (and (always-canonical *current-site
*)
1309 (main-site-link *current-site
* :post post-id
:slug
(cdr (assoc :slug post
))
1310 :comment-id comment-id
:direct-comment-link t
))))
1311 <link rel
="canonical" href
=canonical-source
>)
1312 <script
>postId
=(with-html-stream-output (:stream stream
) (json:encode-json post-id stream
))</script
>
1313 <script
>alignmentForumPost
=(if (cdr (assoc :af post
)) "true" "false")</script
>
1314 (when (logged-in-userid)
1315 (call-with-server-data 'process-vote-data
(format nil
"/karma-vote/post?post-id=~A" post-id
))))
1316 (retrieve-individual-comment (comment-thread-type)
1317 (let* ((comments (case comment-thread-type
1318 (:comment
(get-post-comments post-id
))
1319 (:answer
(get-post-answers post-id
))))
1320 (target-comment (find comment-id comments
:key
(lambda (c) (cdr (assoc :--id c
))) :test
#'string
=)))
1321 (values comments target-comment
))))
1323 (let ((comment-thread-type (if (string= comment-link-type
"answer") :answer
:comment
)))
1324 (multiple-value-bind (comments target-comment
) (retrieve-individual-comment comment-thread-type
)
1325 (unless target-comment
1326 ;; If the comment was not found, try as an answer, or vice versa.
1327 (setf comment-thread-type
(if (eq comment-thread-type
:comment
) :answer
:comment
)
1328 (values comments target-comment
) (retrieve-individual-comment comment-thread-type
))
1329 (unless target-comment
1330 (error 'lw2-not-found-error
)))
1331 (let* ((*comment-individual-link
* t
)
1332 (display-name (get-username (cdr (assoc :user-id target-comment
))))
1334 ((and (eq comment-thread-type
:answer
)
1335 (not (cdr (assoc :parent-comment-id target-comment
))))
1337 (t "comments on"))))
1338 (emit-page (out-stream :title
(format nil
"~A ~A ~A" display-name verb-phrase title
)
1339 :content-class
"individual-thread-page comment-thread-page"
1340 :social-description
(when-let (x (cdr (assoc :html-body target-comment
))) (extract-excerpt x
))
1341 :extra-head
#'extra-head
)
1343 (format out-stream
"<h1 class=\"post-title\">~A ~A <a href=\"~A\">~A</a></h1>"
1344 (encode-entities display-name
)
1346 (generate-item-link :post post-id
)
1347 (clean-text-to-html title
:hyphenation nil
)))
1348 (output-comments out-stream
"comment" comments target-comment
:chrono chrono
:preview preview
)))))
1349 (let ((post-sequences (get-post-sequences post-id
)))
1350 (emit-page (out-stream :title title
1351 :content-class
(format nil
"post-page comment-thread-page~{ ~A~}"
1352 (list-cond ((cdr (assoc :question post
)) "question-post-page")
1353 (post-sequences "in-sequence")
1354 ((not show-comments
) "no-comments")))
1355 :social-description
(when-let (x (cdr (assoc :html-body post
))) (extract-excerpt x
))
1356 :extra-head
#'extra-head
)
1359 (error-explanation-case (error-to-html condition
)
1360 (lw2-not-allowed-error
1361 <p
>This probably means the post has been deleted or moved back to the author
's drafts.
</p
>)))
1363 (post-body-to-html post
)))
1364 (when (and lw2-auth-token
(equal (logged-in-userid) (cdr (assoc :user-id post
))))
1365 (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>"
1366 (cdr (assoc :--id post
))))
1367 (alist-bind (fm-crosspost foreign-post
) post
1368 (alist-bind (is-crosspost hosted-here
) fm-crosspost
1370 (if-let (crosspost-site-host (backend-magnum-crosspost-site *current-backend
*))
1371 (let* ((*current-site
* (find-site crosspost-site-host
))
1372 (crosspost-site-title (main-site-title *current-site
*)))
1373 (alist-bind (comment-count base-score
) foreign-post
1374 <a class
="crosspost" href
=(generate-item-link :post foreign-post
:absolute t
)>Crossposted
(if hosted-here
"to" "from") (progn crosspost-site-title
)
1375 \ \
((safe (pretty-number (or base-score
0) "point")), (safe (pretty-number (or comment-count
0) "comment"))\
)</a
>))
1376 (error "Could not retrieve crossposted post. magnum-crosspost-site not configured.")))))
1377 (post-nav-links post post-sequences
)
1378 (activate-client-trigger "postLoaded")
1380 (write-string "<script> </script>" out-stream
)
1381 (finish-output out-stream
)
1382 (with-error-html-block ()
1383 ;; Temporary hack to support nominations
1384 (let* ((real-comments (get-post-comments post-id
))
1385 (answers (when (cdr (assoc :question post
))
1386 (get-post-answers post-id
)))
1387 (debate-responses (when (cdr (assoc :debate post
))
1388 (get-post-debate-responses post-id
)))
1389 (posted-at (and (typep *current-backend
* 'backend-lw2
)
1390 (cdr (assoc :posted-at post
))))
1391 (posted-timestamp (and posted-at
(local-time:parse-timestring posted-at
)))
1392 (now (local-time:now
))
1393 (nominations-open nil
)
1394 (reviews-eligible (timerange "2020-01-01" posted-timestamp
"2021-01-01"))
1395 (reviews-open (and reviews-eligible
(timerange "2021-12-14" now
"2022-01-11"))))
1396 (labels ((top-level-property (comment property
)
1397 (or (cdr (assoc property comment
))
1398 (cdr (assoc property
(cdr (assoc :top-level-comment comment
)))))))
1399 (multiple-value-bind (normal-comments nominations reviews
)
1400 (loop for comment in real-comments
1401 if
(top-level-property comment
:nominated-for-review
)
1402 collect comment into nominations
1403 else if
(top-level-property comment
:reviewing-for-review
)
1404 collect comment into reviews
1406 collect comment into normal-comments
1407 finally
(return (values normal-comments nominations reviews
)))
1408 (unless (or nominations reviews
)
1409 (setf normal-comments real-comments
)) ;for caching
1410 (loop for
(name comments open
) in
(list-cond ((or nominations nominations-open
)
1411 (list "nomination" nominations nominations-open
))
1412 ((or reviews reviews-open
)
1413 (list "review" reviews reviews-open
))
1414 ((cdr (assoc :debate post
))
1415 (list "debate-responses" debate-responses nil
))
1416 ((cdr (assoc :question post
))
1417 (list "answer" answers t
))
1419 (list "comment" normal-comments t
)))
1420 do
(output-comments out-stream name comments nil
1422 :overcomingbias-sort
(cdr (assoc :comment-sort-order post
)) :chrono chrono
:preview preview
))))))))))))))
1424 (post-comment :post-id post-id
:need-auth need-auth
))))
1426 (defparameter *edit-post-template
* (compile-template* "edit-post.html"))
1428 (define-page view-edit-post
"/edit-post" (title url section tags post-id link-post
)
1431 (let* ((csrf-token (make-csrf-token))
1432 (post-body (if post-id
(get-post-body post-id
:auth-token
(hunchentoot:cookie-in
"lw2-auth-token"))))
1433 (section (or section
(loop for
(sym . sec
) in
'((:draft .
"drafts") (:meta .
"meta") (:frontpage-date .
"frontpage"))
1434 if
(cdr (assoc sym post-body
)) return sec
1435 finally
(return "all")))))
1436 (emit-page (out-stream :title
(if post-id
"Edit Post" "New Post") :content-class
"edit-post-page")
1437 (render-template* *edit-post-template
* out-stream
1438 :csrf-token csrf-token
1439 :title
(cdr (assoc :title post-body
))
1440 :url
(cdr (assoc :url post-body
))
1441 :question
(cdr (assoc :question post-body
))
1442 :tags-supported
(typep *current-backend
* 'backend-accordius
)
1443 :tags
(when (and post-id
(typep *current-backend
* 'backend-accordius
)) (do-wl-rest-query (format nil
"posts/~a/update_tagset/" post-id
) '()))
1445 :section-list
(loop for
(name desc
) in
'(("all" "All") ("meta" "Meta") ("frontpage" "Frontpage") ("drafts" "Drafts"))
1446 when
(or (string= name section
) (member name
'("drafts" "all") :test
#'string
=))
1447 collect
(alist :name name
:desc desc
:selected
(string= name section
)))
1448 :lesswrong-misc
(typep *current-backend
* 'backend-lw2-misc-features
)
1449 :submit-to-frontpage
(if post-id
(cdr (assoc :submit-to-frontpage post-body
)) t
)
1450 :markdown-source
(or (and post-id
(markdown-source :post post-id
(cdr (assoc :html-body post-body
)))) "")))))
1451 (:post
(text question submit-to-frontpage
)
1452 (let ((lw2-auth-token *current-auth-token
*)
1453 (url (if (string= url
"") nil url
)))
1454 (assert lw2-auth-token
)
1457 (t :body
(postprocess-markdown text
))
1458 (t :title
(or (nonempty-string title
) "Untitled"))
1459 (link-post :url url
)
1460 (t :meta
(or (string= section
"meta") :false
))
1461 ((not post-id
) :is-event nil
)
1462 (t :draft
(or (string= section
"drafts") :false
))
1463 ((typep *current-backend
* 'backend-lw2-misc-features
) :submit-to-frontpage
(and submit-to-frontpage t
))
1464 ((not post-id
) :question
(if question t
:false
))))
1467 ((not link-post
) :url t
)))
1470 (do-lw2-post-edit lw2-auth-token post-id post-data post-unset
)
1471 (do-lw2-post lw2-auth-token post-data
)))
1472 (new-post-id (cdr (assoc :--id new-post-data
))))
1473 (assert new-post-id
)
1474 (when (typep *current-backend
* 'backend-accordius
)
1475 (do-wl-rest-mutate :post
1476 (format nil
"posts/~a/update_tagset/" post-id
)
1479 (setf (markdown-source :post new-post-id
(cdr (assoc :html-body new-post-data
))) text
)
1480 (ignore-errors (get-post-body post-id
:force-revalidate t
))
1481 (redirect (if (js-true (cdr (assoc :draft post-data
)))
1482 (concatenate 'string
(generate-item-link :post new-post-data
) "?need-auth=y")
1483 (generate-item-link :post new-post-data
))))))))
1485 (define-json-endpoint (view-karma-vote forum-site
"/karma-vote")
1486 (let ((auth-token *current-auth-token
*))
1488 (:post
(target target-type
(vote-json :real-name
"vote"))
1489 (let ((vote (safe-decode-json vote-json
)))
1490 (multiple-value-bind (current-vote result
)
1491 (do-lw2-vote auth-token target-type target vote
)
1492 (alist-bind (vote-count base-score af af-base-score extended-score
) result
1493 (let ((vote-buttons (vote-buttons base-score
1495 :af-score
(and af af-base-score
)
1496 :vote-count
(+ vote-count
(if (member (cdr (assoc :karma current-vote
)) '(nil "neutral") :test
#'equal
)
1499 :extended-score extended-score
))
1500 (out (make-hash-table)))
1501 (loop for
(axis . axis-vote
) in current-vote
1502 do
(setf (gethash axis out
) (list* axis-vote
(gethash axis vote-buttons
))))
1505 (delete-easy-handler 'view-karma-vote
)
1507 (define-json-endpoint (view-user-status login-site
"/current-user-status")
1508 (let ((auth-token *current-auth-token
*))
1511 (if (lw2-graphql-query (graphql-query-string "currentUser" nil
'(:--id
)) :auth-token auth-token
)
1512 (sethash (make-hash-table)
1513 "notifications" (check-notifications (logged-in-userid) auth-token
)
1514 "alignmentForumAllowed" (member "alignmentForum" (cdr (assoc :groups
(get-user :user-id
(logged-in-userid)))) :test
#'string
=))
1515 (with-cache-transaction
1516 (cache-del "auth-token-to-userid" auth-token
)
1517 (cache-del "auth-token-to-username" auth-token
)))))))
1519 (hunchentoot:define-easy-handler
(view-check-notifications :uri
"/check-notifications") (format)
1521 (setf (hunchentoot:content-type
*) "application/json")
1522 (if *current-auth-token
*
1523 (let ((notifications-status (check-notifications (logged-in-userid) *current-auth-token
* :full
(string= format
"push"))))
1524 (json:encode-json-to-string notifications-status
)))))
1526 (hunchentoot:define-easy-handler
(view-ignore-user :uri
"/ignore-user") ((csrf-token :request-type
:post
) (target-id :request-type
:post
) (state :request-type
:post
) return
)
1528 (check-csrf-token csrf-token
)
1529 (let ((user-id (logged-in-userid)))
1530 (unless user-id
(error "Not logged in."))
1531 (with-cache-transaction
1532 (let ((ignore-hash (get-ignore-hash user-id
)))
1533 (if (string= state
"ignore")
1534 (setf (gethash target-id ignore-hash
) t
)
1535 (remhash target-id ignore-hash
))
1536 (cache-put "user-ignore-list" user-id ignore-hash
:value-type
:json
))))
1538 (redirect return
))))
1540 (client-defun comment-controls (&key standalone parent-comment-id parent-answer-id edit-comment-id
)
1542 <form method
="post" id
="conversation-form" class
="aligned-form">
1543 <div class
="textarea-container">
1544 <textarea name
="text" oninput
="enableBeforeUnload();"></textarea
>
1545 <span class
="markdown-reference-link">You can use
<a href
="http://commonmark.org/help/" target
="_blank">Markdown
</a
> here.
</span
>
1546 <button type
="button" class
="guiedit-mobile-auxiliary-button guiedit-mobile-help-button">Help
</button
>
1547 <button type
="button" class
="guiedit-mobile-auxiliary-button guiedit-mobile-exit-button">Exit
</button
>
1550 (macrolet ((hidden-var (name)
1551 `(when ,name
<input type
="hidden" name
=,(string-downcase name
) value
=,name
>)))
1552 (hidden-var parent-comment-id
)
1553 (hidden-var parent-answer-id
)
1554 (hidden-var edit-comment-id
))
1555 <input name
="csrf-token" value
=(make-csrf-token) type
="hidden">
1556 <input value
="Submit" type
="submit">
1560 <div class
="posting-controls standalone with-markdown-editor" onsubmit
="disableBeforeUnload();">(with-html-stream-output (inner))</div
>
1563 (define-json-endpoint (view-karma-vote-shortform shortform-site
"/karma-vote/shortform")
1564 (let ((auth-token *current-auth-token
*))
1566 (:get
((offset :type fixnum
:default
0))
1567 (sethash (make-hash-table)
1568 "Comment" (get-shortform-votes auth-token
:offset offset
))))))
1570 (define-component view-comments-index
(index-type)
1571 (:http-args
((offset :type fixnum
)
1572 (limit :type fixnum
)
1573 (view :member
'(nil :alignment-forum
))))
1576 (let* ((want-total (not (or (typep *current-backend
* 'backend-lw2
) (typep *current-backend
* 'backend-ea-forum
)))) ; LW2/EAF can't handle total queries. TODO: handle this in backend.
1577 (shortform (eq index-type
:shortform
))
1578 (with-voting (not (null (and shortform
(logged-in-userid))))))
1579 (multiple-value-bind (title query-view top-nav
)
1581 (shortform (values "Shortform" "shortform" (if (logged-in-userid) (lambda () (comment-controls :standalone t
)))))
1582 (t (values (case view
(:alignment-forum
"Alignment Forum recent comments") (t "Recent comments")) "allRecentComments" nil
)))
1583 (multiple-value-bind (recent-comments total last-modified
)
1584 (if (or (not (eq index-type
:recent-comments
)) offset limit view
(/= (user-pref :items-per-page
) 20))
1585 (let ((*use-alignment-forum
* (eq view
:alignment-forum
)))
1586 (lw2-graphql-query (lw2-query-string :comment
:list
1587 (remove nil
(alist :view query-view
1588 :limit
(or limit
(user-pref :items-per-page
)) :offset offset
)
1590 :context
(if shortform
:shortform
:index
)
1591 :with-total want-total
)))
1592 (get-recent-comments :with-total want-total
))
1593 (handle-last-modified last-modified
)
1595 (view-items-index recent-comments
1597 :extra-head
(lambda ()
1599 (call-with-server-data 'process-vote-data
(format nil
"/karma-vote/shortform?offset=~A" (or offset
0)))))
1600 :content-class
(if shortform
"index-page shortform-index-page comment-thread-page" "index-page comment-index-page")
1601 :pagination
(pagination-nav-bars :offset
(or offset
0) :with-next
(not want-total
) :total
(if want-total total
))
1602 :top-nav
(lambda () (page-toolbar-to-html :title title
) (when top-nav
(funcall top-nav
)))
1603 :alternate-html
(if (eq index-type
:shortform
)
1605 (let ((*enable-voting
* with-voting
))
1606 <div class
="comments">
1607 (comment-tree-to-html *html-output
*
1608 (make-comment-parent-hash
1609 (flatten-shortform-comments recent-comments
)))
1612 (post-comment :shortform t
))))
1614 (define-component-routes forum-site
(view-recent-comments (standard-route :uri
"/recentcomments") () (view-comments-index :recent-comments
)))
1615 (define-component-routes shortform-site
(view-shortform (standard-route :uri
"/shortform") () (view-comments-index :shortform
)))
1617 (delete-easy-handler 'view-recent-comments
)
1619 (defun tag-to-html (tag &key skip-headline
)
1620 (schema-bind (:tag tag
:auto
:context
:body
)
1621 (alist-bind (edited-at html user-id
) description
1622 (unless skip-headline
1623 <h1 class
="post-title">(safe (clean-text-to-html name
))</h1
>
1624 <div class
="post-meta">
1625 <span
>(if core
"Core ")(if wiki-only
"Wiki" "Tag")</span
>
1626 (when (and (nonempty-string edited-at
) (nonempty-string user-id
))
1627 <span
>Last edit
: (pretty-time-html edited-at
)
1628 \ by
<a class
="author" href
=("/users/~A" (get-user-slug user-id
))>(get-username user-id
)</a
>
1632 <div class
="tag-description body-text">(with-html-stream-output (:stream stream
) (let ((*memoized-output-stream
* stream
)) (clean-html* html
)))</div
>))))
1634 (defun tag-list-to-html (tags)
1635 <ul class
="tag-list">
1636 (iter (for tag in tags
)
1637 (schema-bind (:tag tag
:auto
:context
:index
)
1638 <li
><a class
="post-title-link" href
=("/tag/~A" slug
)>(safe (clean-text-to-html name
))(if wiki-only
1640 (if post-count
(format nil
" (~A)" post-count
)))</a
></li
>))
1643 (define-json-endpoint (view-user-autocomplete forum-site
"/-user-autocomplete")
1646 (lw2-search-query q
:indexes
'(:users
)))))
1648 (define-json-endpoint (view-karma-vote-tag forum-site
"/karma-vote/tag")
1649 (let ((auth-token *current-auth-token
*))
1651 (:get
(tag-id post-id
)
1652 (hash-cond (make-hash-table)
1653 (tag-id "Post" (get-tag-post-votes tag-id auth-token
))
1654 (tag-id "Comment" (get-tag-comments-votes tag-id auth-token
))
1655 (post-id "Tag" (get-post-tag-votes post-id auth-token
)))))))
1657 (define-component view-tag
(slug tail
)
1658 (:http-args
((sort :default
:relevant
:member
'(:relevant
:new
:old
))))
1659 (when (nonempty-string tail
)
1660 (redirect (format nil
"/tag/~A" slug
))
1662 (let ((tag (first (lw2-graphql-query (lw2-query-string :tag
:list
(alist :view
"tagBySlug" :slug slug
) :context
:body
)))))
1664 (error 'lw2-not-found-error
))
1667 (let* ((posts (get-tag-posts slug
))
1668 (posts (if (eq sort
:relevant
) posts
(sort-items posts sort
))))
1669 (schema-bind (:tag tag
:auto
:context
:body
)
1671 (view-items-index posts
1672 :title
(format nil
"~A tag" name
)
1673 :extra-head
(lambda ()
1674 (when-let (canonical-source (and (always-canonical *current-site
*)
1675 (main-site-link *current-site
* :tag slug
)))
1676 <link rel
="canonical" href
=canonical-source
>)
1677 (when (logged-in-userid)
1678 (call-with-server-data 'process-vote-data
(format nil
"/karma-vote/tag?tag-id=~A" tag-id
))))
1680 (page-toolbar-to-html :title name
:rss
(not wiki-only
))
1682 (when (and posts
(not *preview
*))
1683 (sublevel-nav-to-html '(:relevant
:new
:old
)
1687 :extra-class
"sort")))
1688 :content-class
"index-page tag-index-page"
1689 :alternate-html
(lambda ()
1691 (write-index-items-to-html *html-output
* posts
))
1692 (when (typep *current-backend
* 'backend-lw2-tags-comments
)
1693 (finish-output *html-output
*)
1694 (let ((*enable-voting
* (not (null (logged-in-userid))))
1695 (comments (lw2-graphql-query (lw2-query-string :comment
:list
(alist :view
"tagDiscussionComments" :tag-id tag-id
)))))
1696 (output-comments *html-output
* "comment" comments nil
:replies-open t
)))))))))
1698 (schema-bind (:tag tag
(tag-id))
1700 (post-comment :tag-id tag-id
)))))))
1702 (define-component-routes forum-site
(view-tag (regex-route :regex
"^/(?:tag|topics)/([^/?]+)(/[^/?]*)?") (slug tail
) (view-tag slug tail
)))
1704 (define-route 'ea-forum-viewer-site
'regex-route
:name
'view-tags-redirect
:regex
"^/tag/" :handler
(lambda () (redirect (ppcre:regex-replace
"^/tag/" (hunchentoot:request-uri
*) "/topics/"))))
1706 (define-component view-tags-index
()
1708 (multiple-value-bind (all-tags portal
)
1709 (lw2-graphql-query-multi
1710 (list (lw2-query-string* :tag
:list
(alist :view
"allTagsAlphabetical"))
1711 (lw2-query-string* :tag
:list
(alist :view
"tagBySlug" :slug
"portal") :context
:body
)))
1713 (iter (for tag in all-tags
)
1714 (schema-bind (:tag tag
(core))
1715 (when core
(collect tag
)))))
1716 (title (if (typep *current-site
* 'lesswrong-viewer-site
) "Concepts Portal" "Tags Portal")))
1718 (emit-page (out-stream :title title
)
1720 <h1 class
="post-title">(safe title
)</h1
>
1721 (tag-to-html (first portal
) :skip-headline t
)
1723 (iter (for (title . tags
) in
(alist "Core Tags" core-tags
"All Tags" all-tags
))
1725 <h1
>(safe title
)</h1
>
1726 (tag-list-to-html tags
))))))))
1728 (define-component-routes forum-site
(view-tags-index (standard-route :uri
"/tags") () (view-tags-index)))
1729 (define-component-routes forum-site
(view-tags-index-alt (standard-route :uri
"/topics") () (view-tags-index)))
1731 (define-route 'forum-site
'standard-route
:name
'view-tags-index-redirect
:uri
"/tags/all" :handler
(lambda () (redirect "/tags")))
1732 (define-route 'forum-site
'standard-route
:name
'view-tags-index-redirect
:uri
"/topics/all" :handler
(lambda () (redirect "/topics")))
1734 (define-route 'alternate-frontend-site
'standard-route
:name
'view-tags-voting-redirect
:uri
"/tagVoting" :handler
(lambda () (main-site-redirect "/tagVoting")))
1735 (define-route 'alternate-frontend-site
'standard-route
:name
'view-tags-dashboard-redirect
:uri
"/tags/dashboard" :handler
(lambda () (main-site-redirect "/tags/dashboard")))
1737 (hunchentoot:define-easy-handler
(view-push-register :uri
"/push/register") ()
1739 (let* ((data (call-with-safe-json (lambda ()
1740 (json:decode-json-from-string
1741 (hunchentoot:raw-post-data
:force-text t
:external-format
:utf-8
)))))
1742 (subscription (cdr (assoc :subscription data
)))
1743 (cancel (cdr (assoc :cancel data
))))
1746 (make-subscription *current-auth-token
*
1747 (cdr (assoc :endpoint subscription
))
1748 (cdr (assoc :expires
*current-auth-status
*)))
1749 (send-notification (cdr (assoc :endpoint subscription
)) :ttl
120))
1751 (delete-subscription *current-auth-token
*)))
1754 (hunchentoot:define-easy-handler
(view-inbox-redirect :uri
"/push/go-inbox") ()
1756 (redirect (format nil
"/users/~A?show=inbox" *current-user-slug
*))))
1758 (define-page view-user
(:regex
"^/users/(.*?)(?:$|\\?)|^/user" user-slug
) (id
1759 (offset :type fixnum
:default
0)
1760 (show :member
'(:all
:posts
:comments
:drafts
:conversations
:inbox
) :default
:all
)
1761 (sort :member
'(:top
:new
:old
) :default
:new
))
1762 (let* ((auth-token (if (eq show
:inbox
) *current-auth-token
*))
1764 (let ((ui (get-user (cond (user-slug :user-slug
) (id :user-id
)) (or user-slug id
) :auth-token auth-token
)))
1765 (if (and (not (cdr (assoc :deleted ui
))) (cdr (assoc :--id ui
)))
1767 (error 'lw2-user-not-found-error
))))
1768 (user-id (cdr (assoc :--id user-info
)))
1769 (own-user-page (logged-in-userid user-id
))
1770 (display-name (if user-slug
(cdr (assoc :display-name user-info
)) user-id
))
1771 (show-text (if (not (eq show
:all
)) (string-capitalize show
)))
1772 (title (format nil
"~A~@['s ~A~]" display-name show-text
))
1773 (sort-type (case sort
(:top
:score
) (:new
:date
) (:old
:date-reverse
))))
1774 (multiple-value-bind (items total last-modified
)
1777 (get-user-page-items user-id
:posts
:offset offset
:limit
(+ 1 (user-pref :items-per-page
)) :sort-type sort-type
))
1779 (get-user-page-items user-id
:comments
:offset offset
:limit
(+ 1 (user-pref :items-per-page
)) :sort-type sort-type
))
1781 (get-user-page-items user-id
:posts
:drafts t
:offset offset
:limit
(+ 1 (user-pref :items-per-page
)) :auth-token
(hunchentoot:cookie-in
"lw2-auth-token")))
1783 (let ((conversations
1784 (lw2-graphql-query (lw2-query-string :conversation
:list
1785 (alist :view
"userConversations" :limit
(+ 1 (user-pref :items-per-page
)) :offset offset
:user-id user-id
)
1786 :fields
'(:--id
:created-at
:title
(:participants
:display-name
:slug
) :----typename
))
1787 :auth-token
(hunchentoot:cookie-in
"lw2-auth-token"))))
1788 (lw2-graphql-query-map
1790 (lw2-query-string* :message
:total
(alist :view
"messagesConversation" :conversation-id
(cdr (assoc :--id c
)))))
1792 :postprocess
(lambda (c result
)
1793 (acons :messages-total result c
))
1794 :auth-token
(hunchentoot:cookie-in
"lw2-auth-token"))))
1796 (error-explanation-case
1798 (let ((notifications (get-notifications :user-id user-id
:offset offset
:auth-token
(hunchentoot:cookie-in
"lw2-auth-token")))
1799 (last-check (ignore-errors (local-time:parse-timestring
(cdr (assoc :last-notifications-check user-info
))))))
1800 (labels ((check-new (key obj
)
1801 (if (ignore-errors (local-time:timestamp
< last-check
(local-time:parse-timestring
(cdr (assoc key obj
)))))
1802 (acons :highlight-new t obj
)
1804 (check-replied (comment)
1805 (let* ((post-id (cdr (assoc :post-id comment
)))
1806 (comment-id (cdr (assoc :--id comment
)))
1807 (reply-comment-id (check-comment-replied comment-id user-id
)))
1808 (if reply-comment-id
1809 (acons :replied
(list :post post-id
:comment-id reply-comment-id
) comment
)
1811 (lw2-graphql-query-map
1813 (alexandria:switch
((cdr (assoc :document-type n
)) :test
#'string
=)
1815 (lw2-query-string* :comment
:single
1816 (alist :document-id
(cdr (assoc :document-id n
)))
1819 (lw2-query-string* :post
:single
(alist :document-id
(cdr (assoc :document-id n
)))))
1821 (lw2-query-string* :message
:single
(alist :document-id
(cdr (assoc :document-id n
)))
1822 :fields
*messages-index-fields
*))
1826 :postprocess
(lambda (n result
)
1828 (funcall (if (string= (cdr (assoc :document-type n
)) "comment") #'check-replied
#'identity
)
1830 (alexandria:switch
((cdr (assoc :document-type n
)) :test
#'string
=)
1831 ("comment" :posted-at
)
1833 ("message" :created-at
))
1836 :auth-token auth-token
)))
1838 (hunchentoot:cookie-in
"lw2-auth-token")
1840 (alist :last-notifications-check
(timestamp-to-graphql (local-time:now
)))))
1841 (lw2-not-allowed-error
1842 <p
>This may mean your login token has expired or become invalid. You can try
<a href
="/login">logging in again
</a
>.
</p
>)))
1844 (get-user-page-items user-id
:both
:offset offset
:limit
(+ 1 (user-pref :items-per-page
)) :sort-type sort-type
)))
1845 (handle-last-modified last-modified
)
1846 (let ((with-next (> (length items
) (+ (if (eq show
:all
) offset
0) (user-pref :items-per-page
))))
1847 (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
1848 (view-items-index interleave
:title title
1849 :content-class
(format nil
"user-page~@[ ~A-user-page~]~:[~; own-user-page~]" (string-downcase show
) own-user-page
)
1850 :current-uri
(format nil
"/users/~A" user-slug
)
1852 :pagination
(pagination-nav-bars :offset offset
:total total
:with-next
(if (not total
) with-next
))
1853 :need-auth
(eq show
:drafts
) :section
(if (eq show
:drafts
) "drafts" nil
)
1855 (page-toolbar-to-html :title title
1856 :enable-push-notifications
(eq show
:inbox
)
1857 :rss
(not (member show
'(:drafts
:conversations
:inbox
)))
1858 :new-post
(if (eq show
:drafts
) "drafts" t
)
1859 :new-conversation
(if own-user-page t user-slug
)
1860 :ignore
(if (and (logged-in-userid) (not own-user-page
))
1862 (let ((ignored (gethash user-id
*current-ignore-hash
*)))
1863 <form method
="post" action
="/ignore-user">
1864 <button class
=("button ~A" (if ignored
"unignore-button" "ignore-button"))>(if ignored
"Unignore user" "Ignore user")</button
>
1865 <input type
="hidden" name
="csrf-token" value
=(make-csrf-token)>
1866 <input type
="hidden" name
="target-id" value
=user-id
>
1867 <input type
="hidden" name
="state" value
=(if ignored
"unignore" "ignore")>
1868 <input type
="hidden" name
="return" value
=(hunchentoot:request-uri
*)>
1870 :logout own-user-page
)
1871 (alist-bind ((actual-id string
:--id
)
1872 (actual-slug string
:slug
)
1873 (karma (or null fixnum
))
1874 (af-karma (or null fixnum
)))
1876 <h1 class
="page-main-heading"
1877 (when (not own-user-page
)
1878 (format nil
"data-~:[~;anti-~]~:*kibitzer-redirect=~:[/users/~*~A~;/user?id=~A~]"
1879 user-slug actual-id actual-slug
))>
1880 (progn display-name
)
1881 (let ((full-name (get-user-full-name user-id
)))
1882 (when (and user-slug
(stringp full-name
) (> (length full-name
) 0))
1883 <span class
="user-full-name">\
((progn full-name
)\
)</span
>))
1885 <div class
="user-stats">
1887 <span class
="karma-type">
1888 <span class
="karma-total">(if user-slug
(pretty-number (or karma
0)) "##")</span
>(if af-karma
" (LW),")
1891 <span class
="karma-type">
1892 <span class
="karma-total af-karma-total">(if user-slug
(pretty-number (or af-karma
0)) "##")</span
> \
(AF\
)
1895 (when-let (html-bio (cdr (assoc :html-bio user-info
)))
1896 <div class
="user-bio body-text">
1897 (with-html-stream-output (:stream stream
)
1898 (let ((*memoized-output-stream
* stream
))
1899 (clean-html* html-bio
)))
1901 (sublevel-nav-to-html `(:all
:posts
:comments
1903 '(:drafts
:conversations
:inbox
)))
1906 (when (member show
'(:all
:posts
:comments
))
1907 (sublevel-nav-to-html '(:new
:top
:old
)
1911 :extra-class
"sort"))))))))
1913 (defparameter *conversation-template
* (compile-template* "conversation.html"))
1915 (define-page view-conversation
"/conversation" (id to subject
)
1919 ((and id to
) (error "This is an invalid URL."))
1921 (multiple-value-bind (conversation messages
)
1922 (get-conversation-messages id
(hunchentoot:cookie-in
"lw2-auth-token"))
1923 (let ((conversation (rectify-conversation conversation
)))
1924 (view-items-index (nreverse messages
) :content-class
"conversation-page" :need-auth t
:title
(encode-entities (cdr (assoc :title conversation
)))
1925 :top-nav
(lambda () (render-template* *conversation-template
* *html-output
*
1926 :conversation conversation
:csrf-token
(make-csrf-token)))))))
1928 (emit-page (out-stream :title
"New conversation" :content-class
"conversation-page")
1929 (render-template* *conversation-template
* out-stream
1932 :csrf-token
(make-csrf-token))))))
1933 (:post
((text :required t
))
1935 (let ((participant-ids (list (logged-in-userid) (cdar (lw2-graphql-query (lw2-query-string :user
:single
(alist :slug to
) :fields
'(:--id
)))))))
1936 (do-create-conversation (hunchentoot:cookie-in
"lw2-auth-token") (alist :participant-ids participant-ids
:title subject
))))))
1937 (do-create-message (hunchentoot:cookie-in
"lw2-auth-token") id text
)
1938 (redirect (format nil
"/conversation?id=~A" id
))))))
1940 (defun search-result-markdown-to-html (item)
1941 (cons (cons :html-body
1942 (handler-case (nth-value 1 (cl-markdown:markdown
(cdr (assoc :body item
)) :stream nil
))
1943 (serious-condition () "[Error while processing search result]")))
1946 (define-page view-search
"/search" ((q :required t
))
1947 (let ((*current-search-query
* q
)
1948 (link (presentable-link q
:search
))
1949 (title (format nil
"~@[~A - ~]Search" q
)))
1950 (declare (special *current-search-query
*))
1953 (multiple-value-bind (tags posts comments
) (lw2-search-query q
)
1954 (let ((tags (map 'list
(lambda (tag)
1955 (alist* :----typename
"Tag" tag
))
1957 (view-items-index (nconc
1958 (map 'list
(lambda (post) (if (cdr (assoc :comment-count post
)) post
(alist* :comment-count
0 post
))) posts
)
1959 (map 'list
#'search-result-markdown-to-html comments
))
1961 (page-toolbar-to-html :title title
:rss t
)
1964 (tag-list-to-html tags
)))
1965 :content-class
"search-results-page" :current-uri
"/search"
1968 (defgeneric view-login
(backend))
1970 (defmethod view-login ((backend backend-password-login
))
1971 (with-http-args (return cookie-check
1972 (login-username :request-type
:post
) (login-password :request-type
:post
)
1973 (signup-username :request-type
:post
) (signup-email :request-type
:post
) (signup-password :request-type
:post
) (signup-password2 :request-type
:post
))
1975 ((emit-login-page (&key error-message
)
1976 (let ((csrf-token (make-csrf-token)))
1977 (emit-page (out-stream :title
"Log in" :current-uri
"/login" :content-class
"login-page" :robots
"noindex, nofollow")
1979 (format out-stream
"<div class=\"error-box\">~A</div>" error-message
))
1980 (with-outputs (out-stream) "<div class=\"login-container\">")
1981 (output-form out-stream
"post" (format nil
"/login~@[?return=~A~]" (if return
(url-rewrite:url-encode return
))) "login-form" "Log in" csrf-token
1982 '(("login-username" "Username" "text" "username")
1983 ("login-password" "Password" "password" "current-password"))
1985 :end-html
(when (typep *current-backend
* 'backend-websocket-login
) ;other backends not supported yet
1986 "<a href=\"/reset-password\">Forgot password</a>"))
1987 (output-form out-stream
"post" (format nil
"/login~@[?return=~A~]" (if return
(url-rewrite:url-encode return
))) "signup-form" "Create account" csrf-token
1988 '(("signup-username" "Username" "text" "username")
1989 ("signup-email" "Email" "text" "email")
1990 ("signup-password" "Password" "password" "new-password")
1991 ("signup-password2" "Confirm password" "password" "new-password"))
1993 (if-let (main-site-title (main-site-title *current-site
*))
1994 (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>"
1996 (format out-stream
"</div>"))))
1997 (finish-login (username user-id auth-token error-message
&optional expires
)
2000 (set-cookie "lw2-auth-token" auth-token
:max-age
(if expires
(+ (- expires
(get-unix-time)) (* 24 60 60)) (1- (expt 2 31))))
2001 (if expires
(set-cookie "lw2-status" (json:encode-json-to-string
(alist :expires expires
))))
2002 (cache-put "auth-token-to-userid" auth-token user-id
)
2003 (cache-put "auth-token-to-username" auth-token username
)
2004 (redirect (if (and return
(ppcre:scan
"^/[^/]" return
)) return
"/")))
2006 (emit-login-page :error-message error-message
)))))
2008 ((not (or cookie-check
(hunchentoot:cookie-in
"session-token")))
2009 (set-cookie "session-token" (base64:usb8-array-to-base64-string
(ironclad:make-random-salt
)))
2010 (redirect (format nil
"/login?~@[return=~A&~]cookie-check=y" (if return
(url-rewrite:url-encode return
)))))
2012 (if (hunchentoot:cookie-in
"session-token")
2013 (redirect (format nil
"/login~@[?return=~A~]" (if return
(url-rewrite:url-encode return
))))
2014 (emit-page (out-stream :title
"Log in" :current-uri
"/login")
2015 (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
))))))
2018 ((or (string= login-username
"") (string= login-password
"")) (emit-login-page :error-message
"Please enter a username and password"))
2019 ((lw2.dnsbl
:dnsbl-check
(hunchentoot:real-remote-addr
)) (emit-login-page :error-message
"Your IP address is blacklisted."))
2020 (t (multiple-value-call #'finish-login login-username
(do-login login-username login-password
)))))
2023 ((not (every (lambda (x) (not (string= x
""))) (list signup-username signup-email signup-password signup-password2
)))
2024 (emit-login-page :error-message
"Please fill in all fields"))
2025 ((not (string= signup-password signup-password2
))
2026 (emit-login-page :error-message
"Passwords do not match"))
2027 ((lw2.dnsbl
:dnsbl-check
(hunchentoot:real-remote-addr
)) (emit-login-page :error-message
"Your IP address is blacklisted."))
2028 (t (multiple-value-call #'finish-login signup-username
(do-lw2-create-user signup-username signup-email signup-password
)))))
2030 (emit-login-page))))))
2032 (defmethod view-logout ((backend backend-password-login
))
2035 (set-cookie "lw2-auth-token" "" :max-age
0)
2036 (do-logout *current-auth-token
*)
2039 (defparameter *reset-password-template
* (compile-template* "reset-password.html"))
2041 (define-component basic-reset-password
()
2042 (:http-args
((email :request-type
:post
) (reset-link :request-type
:post
) (password :request-type
:post
) (password2 :request-type
:post
)))
2044 (labels ((emit-rpw-page (&key message message-type step
)
2045 (let ((csrf-token (make-csrf-token)))
2046 (emit-page (out-stream :title
"Reset password" :content-class
"reset-password" :robots
"noindex, nofollow")
2047 (render-template* *reset-password-template
* out-stream
2048 :csrf-token csrf-token
2049 :reset-link reset-link
2051 :message-type message-type
2055 (multiple-value-bind (ret error
)
2056 (do-lw2-forgot-password email
)
2057 (declare (ignore ret
))
2059 (emit-rpw-page :step
1 :message error
:message-type
"error")
2060 (emit-rpw-page :step
1 :message
"Password reset email sent." :message-type
"success"))))
2062 (ppcre:register-groups-bind
(reset-token) ("(?:reset-password/|^)([^/#]+)$" reset-link
)
2065 (emit-rpw-page :step
2 :message
"Invalid password reset link." :message-type
"error"))
2066 ((not (string= password password2
))
2067 (emit-rpw-page :step
2 :message
"Passwords do not match." :message-type
"error"))
2069 (multiple-value-bind (user-id auth-token error-message
) (do-lw2-reset-password reset-token password
)
2070 (declare (ignore user-id auth-token
))
2072 (error-message (emit-rpw-page :step
2 :message error-message
:message-type
"error"))
2074 (with-error-page (emit-page (out-stream :title
"Reset password" :content-class
"reset-password")
2075 (format out-stream
"<h1>Password reset complete</h1><p>You can now <a href=\"/login\">log in</a> with your new password.</p>"))))))))))
2077 (emit-rpw-page))))))
2079 (define-route 'login-site
'standard-route
:name
'view-login
:uri
"/login" :handler
(lambda () (with-error-page (view-login *current-backend
*))))
2080 (define-route 'login-site
'standard-route
:name
'view-login-oauth2.0-callback
:uri
"/auth/callback" :handler
(lambda () (with-error-page (view-login-oauth2.0-callback
*current-backend
*))))
2082 (define-route 'login-site
'standard-route
:name
'view-logout
:uri
"/logout" :handler
(lambda () (with-error-page (view-logout *current-backend
*))))
2084 (define-component-routes login-site
2085 (basic-reset-password (standard-route :uri
"/reset-password") () (basic-reset-password)))
2087 (defun oauth2.0-login-request-uri
(backend path
&optional query
)
2090 (quri:make-uri
:path path
:query query
)
2091 (quri:uri
(oauth2.0-login-uri backend
)))))
2093 (defmethod view-login ((backend backend-oauth2.0-login
))
2094 (with-http-args (return)
2095 (set-cookie "session-token" (base64:usb8-array-to-base64-string
(ironclad:make-random-salt
)))
2097 (oauth2.0-login-request-uri backend
"authorize"
2098 (alist "response_type" "code"
2099 "client_id" (oauth2.0-client-id backend
)
2100 "redirect_uri" (quri:render-uri
(quri:merge-uris
(quri:uri
"/auth/callback") (quri:uri
(site-uri *current-site
*))))
2101 "scope" "openid profile email"
2104 (defmethod view-login-oauth2.0-callback
((backend backend-oauth2.0-login
))
2105 (with-http-args (code state
)
2106 (let ((auth-response
2107 (call-with-http-response #'json
:decode-json
2108 (oauth2.0-login-request-uri backend
"oauth/token")
2110 :content
(alist "grant_type" "authorization_code"
2111 "client_id" (oauth2.0-client-id backend
)
2112 "client_secret" (oauth2.0-client-secret backend
)
2114 "redirect_uri" (quri:render-uri
(quri:merge-uris
(quri:uri
"/auth/callback") (quri:uri
(site-uri *current-site
*)))))
2115 :want-stream t
:force-string t
)))
2116 (alist-bind ((access-token (or null simple-string
) :access--token
)
2117 (error (or null simple-string
))
2118 (error-description (or null simple-string
) :error--description
))
2121 (error "Login error: ~A" (cdr (assoc :error--description auth-response
))))
2122 (unless access-token
2123 (error "Login error: server did not provide an access token."))
2124 (let ((auth-token (do-login-with-oidc-access-token access-token
)))
2125 (alist-bind ((user-id simple-string
:--id
)
2126 (username simple-string
:display-name
))
2128 auth-token
(alist "query"
2129 (graphql-query-string :current-user nil
'(:--id
:display-name
))))
2130 (cache-put "auth-token-to-userid" auth-token user-id
)
2131 (cache-put "auth-token-to-username" auth-token username
))
2132 (set-cookie "lw2-auth-token" auth-token
:max-age
(1- (expt 2 31)))
2133 (redirect (if (and state
(ppcre:scan
"^/[^/]" state
)) state
"/")))))))
2135 (defmethod view-logout ((backend backend-oauth2.0-login
))
2138 (set-cookie "lw2-auth-token" "" :max-age
0)
2140 (oauth2.0-login-request-uri backend
"v2/logout" (alist "client_id" (oauth2.0-client-id backend
)))))))
2142 (delete-easy-handler 'view-login
)
2143 (delete-easy-handler 'view-logout
)
2144 (delete-easy-handler 'view-reset-password
)
2146 (define-page view-library
"/library"
2147 ((view :member
'(:featured
:community
) :default
:featured
))
2150 (lw2-query-string :sequence
:list
2151 (alist :view
(case view
2152 (:featured
"curatedSequences")
2153 (:community
"communitySequences")))
2154 :fields
'(:--id
:created-at
:user-id
:title
:----typename
)))))
2157 :title
"Sequences Library"
2158 :content-class
"sequences-page"
2159 :current-uri
"/library"
2161 (sublevel-nav-to-html '(:featured
:community
)
2165 :extra-class
"sequences-view")))))
2167 (define-page view-sequence
(:regex
"^/s(?:equences)?/([^/?#]+)(?:/?$|\\?)" sequence-id
) ()
2168 (let ((sequence (get-sequence sequence-id
)))
2169 (alist-bind ((title string
))
2171 (emit-page (out-stream
2173 :content-class
"sequence-page")
2174 (sequence-to-html sequence
)))))
2176 (define-component view-collection
(collection-id) ()
2177 (let ((collection (get-collection collection-id
)))
2179 (emit-page (out-stream :title
(cdr (assoc :title collection
)) :content-class
"sequence-page collection-page")
2180 (collection-to-html collection
)))))
2182 (define-component-routes lesswrong-viewer-site
(view-sequences (standard-route :uri
"/sequences") () (view-collection "oneQyj4pw77ynzwAF")))
2183 (define-component-routes lesswrong-viewer-site
(view-codex (standard-route :uri
"/codex") () (view-collection "2izXHCrmJ684AnZ5X")))
2184 (define-component-routes lesswrong-viewer-site
(view-hpmor (standard-route :uri
"/hpmor") () (view-collection "ywQvGBSojSQZTMpLh")))
2185 (define-component-routes ea-forum-viewer-site
(view-handbook (standard-route :uri
"/handbook") () (view-collection "MobebwWs2o86cS9Rd")))
2187 (define-component-routes forum-site
(view-tags-index (standard-route :uri
"/tags") () (view-tags-index)))
2189 (define-page view-archive
(:regex
"^/archive(?:/(\\d{4})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))"
2190 (year :type
(mod 10000))
2191 (month :type
(integer 1 12))
2192 (day :type
(integer 1 31)))
2193 ((offset :type fixnum
:default
0))
2194 (local-time:with-decoded-timestamp
(:day current-day
:month current-month
:year current-year
:timezone local-time
:+utc-zone
+) (local-time:now
)
2195 (local-time:with-decoded-timestamp
(:day earliest-day
:month earliest-month
:year earliest-year
:timezone local-time
:+utc-zone
+) (earliest-post-time)
2196 (labels ((url-elements (&rest url-elements
)
2197 (declare (dynamic-extent url-elements
))
2198 (format nil
"/~{~A~^/~}" url-elements
))
2200 (let ((out-stream *html-output
*))
2201 (with-outputs (out-stream) "<div class=\"archive-nav\"><div class=\"archive-nav-years\">")
2202 (link-if-not out-stream
(not (or year month day
)) (url-elements "archive") "archive-nav-item-year" "All")
2203 (loop for y from earliest-year to current-year
2204 do
(link-if-not out-stream
(eq y year
) (url-elements "archive" y
) "archive-nav-item-year" y
))
2205 (format out-stream
"</div>")
2207 (format out-stream
"<div class=\"archive-nav-months\">")
2208 (link-if-not out-stream
(not month
) (url-elements "archive" year
) "archive-nav-item-month" "All")
2209 (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)
2210 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
)))
2211 (format out-stream
"</div>"))
2213 (format out-stream
"<div class=\"archive-nav-days\">")
2214 (link-if-not out-stream
(not day
) (url-elements "archive" year month
) "archive-nav-item-day" "All")
2215 (loop for d from
(if (and (= (or year current-year
) earliest-year
) (= (or month current-month
) earliest-month
)) earliest-day
1)
2216 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
)))
2217 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
))
2218 (format out-stream
"</div>"))
2219 (format out-stream
"</div>"))))
2220 (multiple-value-bind (posts total
)
2221 (lw2-graphql-query (lw2-query-string :post
:list
2222 (alist :view
(if day
"new" "top") :limit
51 :offset offset
2223 :after
(if (and year
(not day
)) (format nil
"~A-~A-~A" (or year earliest-year
) (or month
1) (or day
1)))
2224 :before
(if year
(format nil
"~A-~A-~A" (or year current-year
) (or month
12)
2225 (or day
(local-time:days-in-month
(or month
12) (or year current-year
))))))))
2226 (emit-page (out-stream :title
"Archive" :current-uri
"/archive" :content-class
"archive-page"
2227 :top-nav
#'archive-nav
2228 :pagination
(pagination-nav-bars :items-per-page
50 :offset offset
:total total
:with-next
(if total nil
(> (length posts
) 50))))
2229 (write-index-items-to-html out-stream
(firstn posts
50) :empty-message
"No posts for the selected period.")))))))
2231 (define-page view-about
"/about" ()
2232 (emit-page (out-stream :title
"About" :current-uri
"/about" :content-class
"about-page")
2233 (alexandria:with-input-from-file
(in-stream "www/about.html" :element-type
'(unsigned-byte 8))
2234 (alexandria:copy-stream in-stream out-stream
))))
2236 (define-page misc-pages
(:regex
"^/misc-pages/.+") ()
2237 (let ((pathname (hunchentoot:request-pathname
)))
2238 (unless (probe-file pathname
)
2239 (error 'lw2-not-found-error
))
2240 (emit-page (out-stream :title
"Misc page" :content-class
"misc-page")
2241 (alexandria:with-input-from-file
(in-stream pathname
:element-type
'(unsigned-byte 8))
2242 (alexandria:copy-stream in-stream out-stream
)))))
2244 (define-page view-generated-script
(:regex
"^/generated/([^/]+)\\.js" (name :type string
)) ()
2245 (when-let ((package (find-package (string-upcase name
))))
2246 (setf (hunchentoot:header-out
"Content-Type") "text/javascript")
2247 (let ((stream (make-flexi-stream (hunchentoot:send-headers
) :external-format
:utf-8
)))
2248 (write-package-client-scripts package stream
))))
2250 (hunchentoot:define-easy-handler
2254 (multiple-value-bind (match? strings
) (ppcre:scan-to-strings
"^/proxy-assets/([0-9A-Za-z]+)(-inverted)?$" (hunchentoot:script-name r
) :sharedp t
)
2255 (when-let* ((base-filename (and match?
(svref strings
0)))
2256 (image-data (cache-get "cached-images" base-filename
:value-type
:json
)))
2257 (let ((inverted (svref strings
1)))
2258 (alist-bind ((mime-type simple-string
)) image-data
2259 (setf (hunchentoot:header-out
"X-Content-Type-Options") "nosniff"
2260 (hunchentoot:header-out
"Cache-Control") #.
(format nil
"public, max-age=~A, immutable" 600))
2261 (hunchentoot:handle-static-file
(concatenate 'string
"www/proxy-assets/" base-filename
(if inverted
"-inverted" "")) mime-type
)