1 (uiop:define-package
#:lw2-viewer
2 (:use
#:cl
#:sb-thread
#:flexi-streams
#:djula
3 #:lw2-viewer.config
#:lw2.utils
#:lw2.lmdb
#:lw2.backend
#:lw2.links
#:lw2.clean-html
#:lw2.login
#:lw2.context
#:lw2.sites
#:lw2.components
#:lw2.html-reader
)
5 #:define-regex-handler
#:*fonts-stylesheet-uri
* #:generate-fonts-link
6 #:user-nav-bar
#:*primary-nav
* #:*secondary-nav
* #:*nav-bars
*
7 #:begin-html
#:end-html
))
9 (in-package #:lw2-viewer
)
11 (named-readtables:in-readtable html-reader
)
13 (add-template-directory (asdf:system-relative-pathname
"lw2-viewer" "templates/"))
15 (define-cache-database "auth-token-to-userid" "auth-token-to-username" "comment-markdown-source" "post-markdown-source")
17 (defvar *current-auth-token
*)
18 (defvar *current-userid
*)
19 (defvar *current-username
*)
20 (defvar *current-user-slug
*)
22 (defvar *read-only-mode
* nil
)
23 (defvar *read-only-default-message
* "Due to a system outage, you cannot log in or post at this time.")
25 (defparameter *default-prefs
* (alist :items-per-page
20 :default-sort
"new"))
26 (defvar *current-prefs
* nil
)
28 (defun logged-in-userid (&optional is-userid
)
29 (let ((current-userid *current-userid
*))
31 (string= current-userid is-userid
)
34 (defun logged-in-username ()
37 (defun logged-in-user-slug ()
40 (defun pretty-time (timestring &key format
)
41 (let ((time (local-time:parse-timestring timestring
)))
42 (values (local-time:format-timestring nil time
:timezone local-time
:+utc-zone
+ :format
(or format
'(:day
#\
:short-month
#\
:year
#\
:hour
#\
: (:min
2) #\
:timezone
)))
43 (* (local-time:timestamp-to-unix time
) 1000))))
45 (defun pretty-number (number &optional object
)
46 (let ((str (coerce (format nil
"~:D~@[<span> ~A~P</span>~]" number object number
) '(vector character
))))
47 (if (eq (aref str
0) #\-
)
48 (setf (aref str
0) #\MINUS_SIGN
))
51 (defun generate-post-auth-link (post &optional comment-id absolute need-auth
)
53 (concatenate 'string
(generate-post-link post comment-id absolute
) "?need-auth=y")
54 (generate-post-link post comment-id absolute
)))
56 (defun clean-lw-link (url)
58 (ppcre:regex-replace
"([^/]*//[^/]*)lesserwrong\.com" url
"\\1lesswrong.com")))
60 (defun votes-to-tooltip (votes)
62 (format nil
"~A vote~:*~P"
63 (typecase votes
(integer votes
) (list (length votes
))))
66 (defun post-section-to-html (post &key skip-section
)
67 (alist-bind ((user-id string
)
68 (frontpage-date (or null string
))
69 (curated-date (or null string
))
74 (multiple-value-bind (class title href
)
75 (cond (af (if (eq skip-section
:alignment-forum
) nil
(values "alignment-forum" "View Alignment Forum posts" "/index?view=alignment-forum")))
76 ; show alignment forum even if skip-section is t
77 ((eq skip-section t
) nil
)
79 (curated-date (if (eq skip-section
:featured
) nil
(values "featured" "View Featured posts" "/index?view=featured")))
80 (frontpage-date (if (eq skip-section
:frontpage
) nil
(values "frontpage" "View Frontpage posts" "/")))
81 (meta (if (eq skip-section
:meta
) nil
(values "meta" "View Meta posts" "/index?view=meta")))
82 (t (if (eq skip-section
:personal
) nil
(values "personal" (format nil
"View posts by ~A" (get-username user-id
)) (format nil
"/users/~A?show=posts" (get-user-slug user-id
))))))
83 <a class
=("post-section ~A" class
) title
=title href
=href
></a
>)))
85 (defun post-headline-to-html (post &key skip-section need-auth
)
86 (alist-bind ((post-id string
:--id
)
89 (url (or null string
))
92 (comment-count (or null fixnum
))
93 (page-url (or null string
))
94 (word-count (or null fixnum
))
95 (frontpage-date (or null string
))
96 (curated-date (or null string
))
100 (vote-count (or null fixnum
))
103 (multiple-value-bind (pretty-time js-time
) (pretty-time posted-at
)
104 <h1 class
=("listing~{ ~A~}" (list-cond
105 (url "link-post-listing")
106 (question "question-post-listing")
107 ((logged-in-userid user-id
) "own-post-listing")))>
108 (if url
<a href
=(convert-any-link (string-trim " " url
))>
;</a>)
109 <a href
=(generate-post-auth-link post nil nil need-auth
)>
110 (if question
<span class
="post-type-prefix">[Question] </span>)
111 (safe (clean-text-to-html title))
113 (if (logged-in-userid user-id) <a class="edit-post-link button" href=("/edit-post?post-id=~A" post-id)</a>)
115 <div class="post-meta">
116 <a class=("author~{ ~A~}" (list-cond ((logged-in-userid user-id) "own-user-author")))
117 href=("/users/~A" (get-user-slug user-id))
119 (get-username user-id)
121 <div class="date" data-js-date=js-time>(progn pretty-time)</div>
123 <span class="karma-value" title=(votes-to-tooltip vote-count)>(safe (pretty-number base-score "point"))</span>
125 <a class="comment-count" href=("~A#comments" (generate-post-link post))>(safe (pretty-number (or comment-count 0) "comment"))</a>
126 (if word-count <span class="read-time" title=(safe (pretty-number word-count "word"))>(max 1 (round word-count 300))<span> min read</span></span>)
127 (if page-url <a class="lw2-link" href=(clean-lw-link page-url)>(main-site-abbreviation *current-site*)<span> link</span></a>)
128 (with-html-stream-output (post-section-to-html post :skip-section skip-section))
129 (if url <div class="link-post-domain">("(~A)" (puri:uri-host (puri:parse-uri (string-trim " " url))))</div>)
132 (defun post-body-to-html (post)
133 (alist-bind ((post-id string :--id)
136 (url (or null string))
139 (tags (or null list))
140 (comment-count (or null fixnum))
141 (page-url (or null string))
142 (frontpage-date (or null string))
143 (curated-date (or null string))
148 (vote-count (or null fixnum))
149 (html-body (or null string)))
151 (multiple-value-bind (pretty-time js-time) (pretty-time posted-at)
152 <div class=("post~{ ~A~}" (list-cond
154 (question "question-post")))>
155 <h1 class="post-title">
156 (if question <span class="post-type-prefix">[Question] </span
>)
157 (safe (clean-text-to-html title
:hyphenation nil
))
159 <div class
="post-meta">
160 <a class
=("author~{ ~A~}" (list-cond
161 ((logged-in-userid user-id
) "own-user-author")))
162 href
=("/users/~A" (get-user-slug user-id
))
164 (get-username user-id
)
166 <div class
="date" data-js-date
=js-time
>(progn pretty-time
)</div
>
167 <div class
="karma" data-post-id
=post-id
>
168 <span class
="karma-value" title
=(votes-to-tooltip vote-count
)>(safe (pretty-number base-score
"point"))</span
>
170 <a class
="comment-count" href
="#comments">(safe (pretty-number (or comment-count
0) "comment"))</a
>
171 (if page-url
<a class
="lw2-link" href
=(clean-lw-link page-url
)>(main-site-abbreviation *current-site
*)<span
> link
</span
></a
>)
172 (with-html-stream-output (post-section-to-html post
))
175 (dolist (tag tags
) (alist-bind ((text string
)) tag
<a href
=("/tags/~A" text
)>(progn text
)</a
>))
178 <div class
="post-body">
179 (if url
<p
><a class
="link-post-link" href
=(convert-any-link (string-trim " " url
))>Link post
</a
></p
>)
180 (with-html-stream-output
181 (write-sequence (clean-html* (or html-body
"") :with-toc t
:post-id post-id
) *html-output
*))
185 (defparameter *comment-individual-link
* nil
)
187 (defun comment-to-html (out-stream comment
&key with-post-title
)
188 (if (or (cdr (assoc :deleted comment
)) (cdr (assoc :deleted-public comment
)))
189 (format out-stream
"<div class=\"comment deleted-comment\"><div class=\"comment-meta\"><span class=\"deleted-meta\">[ ]</span></div><div class=\"comment-body\">[deleted]</div></div>")
190 (alist-bind ((comment-id string
:--id
)
193 (highlight-new boolean
)
196 (page-url (or null string
))
197 (parent-comment list
)
198 (parent-comment-id (or null string
))
199 (child-count (or null fixnum
))
201 (vote-count (or null fixnum
))
204 (parent-answer-id (or null string
))
207 (multiple-value-bind (pretty-time js-time
) (pretty-time posted-at
)
208 <div class
=("comment~{ ~A~}"
210 ((and (logged-in-userid user-id
)
211 (< (* 1000 (local-time:timestamp-to-unix
(local-time:now
))) (+ js-time
15000)))
212 "just-posted-comment")
213 (highlight-new "comment-item-highlight")
214 (retracted "retracted")))>
215 <div class
="comment-meta">
216 <a class
=("author~:[~; own-user-author~]" (logged-in-userid user-id
))
217 href
=("/users/~A" (encode-entities (get-user-slug user-id
)))
219 (get-username user-id
)
221 <a class
="date" href
=(generate-post-link post-id comment-id
) data-js-date
=js-time
> (safe pretty-time
) </a
>
223 <span class
="karma-value" title
=(votes-to-tooltip vote-count
)> (safe (pretty-number base-score
"point")) </span
>
225 <a class
="permalink" href
=("~A/~A/~A"
226 (generate-post-link post-id
)
227 (cond ((or answer parent-answer-id
) "answer") (t "comment"))
229 title
="Permalink"></a
>
230 (with-html-stream-output
232 <a class
="lw2-link" href
=(clean-lw-link page-url
) title
=(main-site-abbreviation *current-site
*)></a
>)
234 <div class
="comment-post-title">
235 (with-html-stream-output
237 (alist-bind ((user-id string
)
239 (parent-id string
:--id
))
241 <span class
="comment-in-reply-to">in reply to
:
242 <a href
=("/users/~A" (get-user-slug user-id
))
243 class
=("inline-author~:[~; own-user-author~]" (logged-in-userid user-id
))
244 data-userid
=(progn user-id
)>
245 (get-username user-id
)</a
>'s
246 <a href
=(generate-post-link post-id parent-id
)>comment
</a
>
249 <span class
="comment-post-title2">on
: <a href
=(generate-post-link post-id
)>(safe (clean-text-to-html (get-post-title post-id
)))</a
></span
>
251 (when parent-comment-id
252 (if *comment-individual-link
*
253 <a class
="comment-parent-link" href
=(progn parent-comment-id
) title
="Parent"></a
>
254 <a class
="comment-parent-link" href
=("#comment-~A" parent-comment-id
)>Parent
</a
>)))
256 <div class
="comment-child-links">
258 (with-html-stream-output
259 (dolist (child children
)
260 (alist-bind ((comment-id string
)
263 <a href
=("#comment-~A" comment-id
)>(">~A" (get-username user-id
))</a
>)))
265 <div class
="comment-minimize-button"
266 data-child-count
=(progn child-count
)>
269 <div class
="comment-body" (safe ("~@[ data-markdown-source=\"~A\"~]"
270 (if (logged-in-userid user-id
)
272 (or (cache-get "comment-markdown-source" comment-id
)
274 (with-html-stream-output (write-sequence (clean-html* html-body
) out-stream
))
278 (defun postprocess-conversation-title (title)
279 (if (or (null title
) (string= title
""))
280 "[Untitled conversation]"
283 (defun conversation-message-to-html (out-stream message
)
284 (alist-bind ((user-id string
)
286 (highlight-new boolean
)
289 (html-body (or string null
)))
291 (multiple-value-bind (pretty-time js-time
) (pretty-time created-at
)
292 (format out-stream
"<div class=\"comment private-message~A\"><div class=\"comment-meta\"><a class=\"author\" href=\"/users/~A\">~A</a> <span class=\"date\" data-js-date=\"~A\">~A</span><div class=\"comment-post-title\">Private message in: <a href=\"/conversation?id=~A\">~A</a></div></div><div class=\"comment-body\">"
293 (if highlight-new
" comment-item-highlight" "")
294 (encode-entities (get-user-slug user-id
))
295 (encode-entities (get-username user-id
))
298 (encode-entities (cdr (assoc :--id conversation
)))
299 (encode-entities (postprocess-conversation-title (cdr (assoc :title conversation
))))))
301 (write-sequence (clean-html* html-body
) out-stream
)
302 (format out-stream
"~{<p>~A</p>~}" (loop for block in
(cdr (assoc :blocks content
)) collect
(encode-entities (cdr (assoc :text block
))))))
303 (format out-stream
"</div></div>")))
305 (defun conversation-index-to-html (out-stream conversation
)
306 (alist-bind ((conversation-id string
:--id
)
307 (title (or null string
))
308 (created-at (or null string
))
310 (messages-total fixnum
))
312 (multiple-value-bind (pretty-time js-time
) (if created-at
(pretty-time created-at
) (values "[Error]" 0))
313 (format out-stream
"<h1 class=\"listing\"><a href=\"/conversation?id=~A\">~A</a></h1><div class=\"post-meta\"><div class=\"conversation-participants\"><ul>~:{<li><a href=\"/users/~A\">~A</a></li>~}</ul></div><div class=\"messages-count\">~A</div><div class=\"date\" data-js-date=\"~A\">~A</div></div>"
314 (encode-entities conversation-id
)
315 (encode-entities (postprocess-conversation-title title
))
316 (loop for p in participants
317 collect
(list (encode-entities (cdr (assoc :slug p
))) (encode-entities (cdr (assoc :display-name p
)))))
318 (pretty-number messages-total
"message")
322 (defun error-to-html (out-stream condition
)
323 (format out-stream
"<div class=\"gw-error\"><h1>Error</h1><p>~A</p></div>"
324 (encode-entities (princ-to-string condition
))))
326 (defmacro with-error-html-block
((out-stream) &body body
)
327 "If an error occurs within BODY, write an HTML representation of the
328 signaled condition to OUT-STREAM."
331 (serious-condition (c) (error-to-html ,out-stream c
))))
333 (defun make-comment-parent-hash (comments)
334 (let ((existing-comment-hash (make-hash-table :test
'equal
))
335 (hash (make-hash-table :test
'equal
)))
337 (alexandria:if-let
(id (cdr (assoc :--id c
)))
338 (setf (gethash id existing-comment-hash
) t
)))
340 (let* ((parent-id (cdr (assoc :parent-comment-id c
)))
341 (old (gethash parent-id hash
)))
342 (setf (gethash parent-id hash
) (cons c old
))
343 (when (and parent-id
(not (gethash parent-id existing-comment-hash
)))
344 (let ((placeholder (alist :--id parent-id
:parent-comment-id nil
:deleted t
)))
345 (setf (gethash parent-id existing-comment-hash
) t
346 (gethash nil hash
) (cons placeholder
(gethash nil hash
)))))))
347 (maphash (lambda (k old
)
348 (setf (gethash k hash
) (nreverse old
)))
351 ((count-children (parent)
352 (let ((children (gethash (cdr (assoc :--id parent
)) hash
)))
353 (+ (length children
) (apply #'+ (map 'list
#'count-children children
)))))
354 (add-child-counts (comment-list)
355 (loop for c in comment-list
356 as id
= (cdr (assoc :--id c
))
357 do
(setf (gethash id hash
) (add-child-counts (gethash id hash
)))
358 collecting
(cons (cons :child-count
(count-children c
)) c
))))
359 (setf (gethash nil hash
) (add-child-counts (gethash nil hash
))))
362 (defun comment-thread-to-html (out-stream emit-comment-item-fn
)
363 (format out-stream
"<ul class=\"comment-thread\">")
364 (funcall emit-comment-item-fn
)
365 (format out-stream
"</ul>"))
367 (defun comment-item-to-html (out-stream comment
&key extra-html-fn
)
368 (with-error-html-block (out-stream)
369 (let ((c-id (cdr (assoc :--id comment
))))
370 (format out-stream
"<li id=\"comment-~A\" class=\"comment-item\">" c-id
)
372 (comment-to-html out-stream comment
)
373 (if extra-html-fn
(funcall extra-html-fn c-id
))
374 (format out-stream
"</li>")))))
376 (defun comment-tree-to-html (out-stream comment-hash
&optional
(target nil
) (level 0))
377 (let ((comments (gethash target comment-hash
)))
379 (comment-thread-to-html out-stream
381 (loop for c in comments do
382 (comment-item-to-html out-stream c
383 :extra-html-fn
(lambda (c-id)
384 (if (and (= level
10) (gethash c-id comment-hash
))
385 (format out-stream
"<input type=\"checkbox\" id=\"expand-~A\"><label for=\"expand-~:*~A\" data-child-count=\"~A comment~:P\">Expand this thread</label>"
387 (cdr (assoc :child-count c
))))
388 (comment-tree-to-html out-stream comment-hash c-id
(1+ level
))))))))))
390 (defun comment-chrono-to-html (out-stream comments
)
391 (let ((comment-hash (make-comment-parent-hash comments
))
392 (comments-sorted (sort comments
#'local-time
:timestamp
< :key
(lambda (c) (local-time:parse-timestring
(cdr (assoc :posted-at c
)))))))
393 (comment-thread-to-html out-stream
395 (loop for c in comments-sorted do
396 (let* ((c-id (cdr (assoc :--id c
)))
397 (new-c (acons :children
(gethash c-id comment-hash
) c
)))
398 (comment-item-to-html out-stream new-c
)))))))
400 (defun comment-post-interleave (list &key limit offset
(sort-by :date
))
401 (multiple-value-bind (sort-fn sort-key
)
403 (:date
(values #'local-time
:timestamp
> (lambda (x) (local-time:parse-timestring
(cdr (assoc :posted-at x
))))))
404 (:score
(values #'> (lambda (x) (cdr (assoc :base-score x
))))))
405 (let ((sorted (sort list sort-fn
:key sort-key
)))
406 (loop for end
= (if (or limit offset
) (+ (or limit
0) (or offset
0)))
409 until
(and end
(>= count end
))
410 when
(or (not offset
) (>= count offset
))
413 (defun write-index-items-to-html (out-stream items
&key need-auth
(empty-message "No entries.") skip-section
)
416 (with-error-html-block (out-stream)
418 ((typep x
'condition
)
419 (error-to-html out-stream x
))
421 (format out-stream
"<p>~A</p>" (cdr (assoc :message x
))))
422 ((string= (cdr (assoc :----typename x
)) "Message")
423 (format out-stream
"<ul class=\"comment-thread\"><li class=\"comment-item\">")
425 (conversation-message-to-html out-stream x
)
426 (format out-stream
"</li></ul>")))
427 ((string= (cdr (assoc :----typename x
)) "Conversation")
428 (conversation-index-to-html out-stream x
))
429 ((assoc :comment-count x
)
430 (post-headline-to-html x
:need-auth need-auth
:skip-section skip-section
))
432 (format out-stream
"<ul class=\"comment-thread\"><li class=\"comment-item\" id=\"comment-~A\">" (cdr (assoc :--id x
)))
434 (comment-to-html out-stream x
:with-post-title t
)
435 (format out-stream
"</li></ul>"))))))
436 (format out-stream
"<div class=\"listing-message\">~A</div>" empty-message
)))
438 (defun write-index-items-to-rss (out-stream items
&key title need-auth
)
439 (let ((full-title (format nil
"~@[~A - ~]~A" title
(site-title *current-site
*))))
440 (xml-emitter:with-rss2
(out-stream :encoding
"UTF-8")
441 (xml-emitter:rss-channel-header full-title
(site-uri *current-site
*) :description full-title
)
442 (labels ((emit-item (item &key title link
(guid (cdr (assoc :--id item
))) (author (get-username (cdr (assoc :user-id item
))))
443 (date (pretty-time (cdr (assoc :posted-at item
)) :format local-time
:+rfc-1123-format
+)) body
)
444 (xml-emitter:rss-item
452 (if (assoc :comment-count item
)
453 (let ((author (get-username (cdr (assoc :user-id item
)))))
455 :title
(clean-text (format nil
"~A by ~A" (cdr (assoc :title item
)) author
))
457 :link
(generate-post-auth-link item nil t need-auth
)
458 :body
(clean-html (or (cdr (assoc :html-body
(get-post-body (cdr (assoc :--id item
)) :revalidate nil
))) "") :post-id
(cdr (assoc :--id item
)))))
460 :title
(format nil
"Comment by ~A on ~A" (get-username (cdr (assoc :user-id item
))) (get-post-title (cdr (assoc :post-id item
))))
461 :link
(generate-post-link (cdr (assoc :post-id item
)) (cdr (assoc :--id item
)) t
)
462 :body
(clean-html (cdr (assoc :html-body item
))))))))))
464 (defparameter *fonts-stylesheet-uris
*
465 '("https://fonts.greaterwrong.com/?fonts=InconsolataGW,CharterGW,ConcourseGW,Whitney,MundoSans,SourceSansPro,Raleway,ProximaNova,TiredOfCourier,AnonymousPro,InputSans,InputSansNarrow,InputSansCondensed,GaramondPremierPro,TriplicateCode,TradeGothic,NewsGothicBT,Caecilia,SourceSerifPro,SourceCodePro"
466 "https://fonts.greaterwrong.com/?fonts=BitmapFonts,FontAwesomeGW&base64encode=1"))
467 ;(defparameter *fonts-stylesheet-uris* '("https://fonts.greaterwrong.com/?fonts=*"))
469 (defvar *fonts-redirect-data
* nil
)
470 (sb-ext:defglobal
*fonts-redirect-lock
* (make-mutex))
471 (sb-ext:defglobal
*fonts-redirect-thread
* nil
)
473 (defun generate-fonts-links ()
474 (let ((current-time (get-unix-time)))
475 (labels ((get-redirects (uri-list)
476 (loop for request-uri in uri-list collect
477 (multiple-value-bind (body status headers uri
)
478 (drakma:http-request request-uri
:method
:head
:close t
:redirect nil
:additional-headers
(alist :referer
(site-uri (first *sites
*)) :accept
"text/css,*/*;q=0.1"))
479 (declare (ignore body uri
))
480 (let ((location (cdr (assoc :location headers
))))
481 (if (and (typep status
'integer
) (< 300 status
400) location
)
486 (let* ((new-redirects (get-redirects *fonts-stylesheet-uris
*))
487 (new-redirects (loop for new-redirect in new-redirects
488 for original-uri in
*fonts-stylesheet-uris
*
489 collect
(if new-redirect
(quri:render-uri
(quri:merge-uris
(quri:uri new-redirect
) (quri:uri original-uri
))) original-uri
))))
490 (with-mutex (*fonts-redirect-lock
*) (setf *fonts-redirect-data
* (list *fonts-stylesheet-uris
* new-redirects current-time
)
491 *fonts-redirect-thread
* nil
))
493 (serious-condition () *fonts-stylesheet-uris
*)))
494 (ensure-update-thread ()
495 (with-mutex (*fonts-redirect-lock
*)
496 (or *fonts-redirect-thread
*
497 (setf *fonts-redirect-thread
* (make-thread #'update-redirects
:name
"fonts redirect update"))))))
498 (destructuring-bind (&optional base-uris redirect-uris timestamp
) (with-mutex (*fonts-redirect-lock
*) *fonts-redirect-data
*)
499 (if (and (eq base-uris
*fonts-stylesheet-uris
*) timestamp
)
501 (if (>= current-time
(+ timestamp
60))
502 (ensure-update-thread))
503 (or redirect-uris
*fonts-stylesheet-uris
*))
504 (update-redirects))))))
506 (defparameter *html-head
*
508 "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">
509 <meta name=\"HandheldFriendly\" content=\"True\" />"))
511 (defparameter *extra-external-scripts
* "")
512 (defparameter *extra-inline-scripts
* "")
514 (defun generate-versioned-link (file)
515 (format nil
"~A?v=~A" file
(sb-posix:stat-mtime
(sb-posix:stat
(format nil
"www~A" file
)))))
517 (defun search-bar-to-html (out-stream)
518 (declare (special *current-search-query
*))
519 (let ((query (and (boundp '*current-search-query
*) (hunchentoot:escape-for-html
*current-search-query
*))))
520 (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
*))))
522 (defun inbox-to-html (out-stream user-slug
&optional new-messages
)
523 (let* ((target-uri (format nil
"/users/~A?show=inbox" user-slug
))
524 (as-link (string= (hunchentoot:request-uri
*) target-uri
)))
525 (multiple-value-bind (nm-class nm-text
)
526 (if new-messages
(values "new-messages" "New messages") (values "no-messages" "Inbox"))
527 (format out-stream
"<~:[a href=\"~A\"~;span~*~] id=\"inbox-indicator\" class=\"~A\" accesskey=\"o\" title=\"~A~:[ [o]~;~]\">~A</a>"
528 as-link target-uri nm-class nm-text as-link nm-text
))))
530 (defmethod site-nav-bars ((site site
))
531 '((:secondary-bar
(("archive" "/archive" "Archive" :accesskey
"r")
532 ("about" "/about" "About" :accesskey
"t")
533 ("search" "/search" "Search" :html search-bar-to-html
)
535 (:primary-bar
(("home" "/" "Home" :description
"Latest frontpage posts" :accesskey
"h")
536 ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description
"Latest comments" :accesskey
"c")))))
538 (defmethod site-nav-bars ((site lesswrong-viewer-site
))
539 '((:secondary-bar
(("archive" "/archive" "Archive" :accesskey
"r")
540 ("about" "/about" "About" :accesskey
"t")
541 ("search" "/search" "Search" :html search-bar-to-html
)
543 (:primary-bar
(("home" "/" "Home" :description
"Latest frontpage posts" :accesskey
"h")
544 ("featured" "/index?view=featured" "Featured" :description
"Latest featured posts" :accesskey
"f")
545 ("all" "/index?view=all" "All" :description
"Latest posts from all sections" :accesskey
"a")
546 ("meta" "/index?view=meta" "Meta" :description
"Latest meta posts" :accesskey
"m")
547 ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description
"Latest comments" :accesskey
"c")))))
549 (defmethod site-nav-bars ((site ea-forum-viewer-site
))
550 '((:secondary-bar
(("archive" "/archive" "Archive" :accesskey
"r")
551 ("about" "/about" "About" :accesskey
"t")
552 ("search" "/search" "Search" :html search-bar-to-html
)
554 (:primary-bar
(("home" "/" "Home" :description
"Latest frontpage posts" :accesskey
"h")
555 ("all" "/index?view=all" "All" :description
"Latest posts from all sections" :accesskey
"a")
556 ("meta" "/index?view=community" "Community" :description
"Latest community posts" :accesskey
"m")
557 ("recent-comments" "/recentcomments" "<span>Recent </span>Comments" :description
"Latest comments" :accesskey
"c")))))
559 (defun prepare-nav-bar (nav-bar current-uri
)
560 (list (first nav-bar
)
561 (map 'list
(lambda (item) (if (listp item
) item
(funcall item current-uri
)))
564 (defun nav-item-active (item current-uri
)
566 (destructuring-bind (id uri name
&key description html accesskey nofollow trailing-html override-uri
) item
567 (declare (ignore id name description html accesskey nofollow trailing-html
))
568 (string= (or override-uri uri
) current-uri
))))
570 (defun nav-bar-active (nav-bar current-uri
)
571 (some (lambda (x) (nav-item-active x current-uri
)) (second nav-bar
)))
573 (defun nav-bar-inner (out-stream items
&optional current-uri
)
574 (maplist (lambda (items)
575 (let ((item (first items
)))
576 (destructuring-bind (id uri name
&key description html accesskey nofollow trailing-html override-uri
) item
577 (declare (ignore override-uri
))
578 (let* ((item-active (nav-item-active item current-uri
))
579 (nav-class (format nil
"nav-item ~:[nav-inactive~;nav-current~]~:[~; nav-item-last-before-current~]"
580 item-active
(and (not item-active
) (nav-item-active (cadr items
) current-uri
)))))
581 (format out-stream
"<span id=\"nav-item-~A\" class=\"~A\" ~@[title=\"~A\"~]>"
582 id nav-class description
)
584 (funcall html out-stream
)
585 (link-if-not out-stream item-active uri
"nav-inner" name
:accesskey accesskey
:nofollow nofollow
))
587 (funcall trailing-html out-stream
))
588 (format out-stream
"</span>")))))
591 (defun nav-bar-outer (out-stream class nav-bar
&optional current-uri
)
592 (format out-stream
"<div id=\"~A\" class=\"nav-bar~@[ ~A~]\">" (string-downcase (first nav-bar
)) class
)
593 (nav-bar-inner out-stream
(second nav-bar
) current-uri
)
594 (format out-stream
"</div>"))
596 (defun nav-bar-to-html (out-stream &optional current-uri
)
597 (let* ((nav-bars (map 'list
(lambda (x) (prepare-nav-bar x current-uri
)) (site-nav-bars *current-site
*)))
598 (active-bar (or (find-if (lambda (x) (nav-bar-active x current-uri
)) nav-bars
) (car (last nav-bars
))))
599 (inactive-bars (remove active-bar nav-bars
)))
600 (dolist (bar inactive-bars
)
601 (nav-bar-outer out-stream
"inactive-bar" bar current-uri
))
602 (nav-bar-outer out-stream
"active-bar" active-bar current-uri
)))
604 (defun user-nav-item (&optional current-uri
)
606 `("login" "/login" "Read Only Mode" :html
,(lambda () (format nil
"<span class=\"nav-inner\" title=\"~A\">[Read Only Mode]</span>"
607 (typecase *read-only-mode
*
608 (string *read-only-mode
*)
609 (t *read-only-default-message
*)))))
610 (alexandria:if-let
(username (logged-in-username))
611 (let ((user-slug (encode-entities (logged-in-user-slug))))
612 `("login" ,(format nil
"/users/~A" user-slug
) ,(plump:encode-entities username
) :description
"User page" :accesskey
"u"
613 :trailing-html
,(lambda (out-stream) (inbox-to-html out-stream user-slug
))))
614 `("login" ,(format nil
"/login?return=~A" (url-rewrite:url-encode current-uri
)) "Log In" :accesskey
"u" :nofollow t
:override-uri
"/login"))))
616 (defun sublevel-nav-to-html (out-stream options current
&key default
(base-uri (hunchentoot:request-uri
*)) (param-name "show") (remove-params '("offset")) extra-class
)
617 (declare (type (or null string
) extra-class
))
618 (format out-stream
"<div class=\"sublevel-nav~@[ ~A~]\">" extra-class
)
619 (loop for item in options
620 do
(multiple-value-bind (param-value text
) (if (atom item
)
621 (values (string-downcase item
) (string-capitalize item
))
623 (let* ((selected (string-equal current param-value
))
624 (class (if selected
"sublevel-item selected" "sublevel-item")))
625 (link-if-not out-stream selected
(apply #'replace-query-params base-uri param-name
(unless (string-equal param-value default
) param-value
)
626 (loop for x in remove-params nconc
(list x nil
)))
628 (format out-stream
"</div>"))
630 (defun make-csrf-token (&optional
(session-token (hunchentoot:cookie-in
"session-token")) (nonce (ironclad:make-random-salt
)))
631 (if (typep session-token
'string
) (setf session-token
(base64:base64-string-to-usb8-array session-token
)))
632 (let ((csrf-token (concatenate '(vector (unsigned-byte 8)) nonce
(ironclad:digest-sequence
:sha256
(concatenate '(vector (unsigned-byte 8)) nonce session-token
)))))
633 (values (base64:usb8-array-to-base64-string csrf-token
) csrf-token
)))
635 (defun check-csrf-token (csrf-token &optional
(session-token (hunchentoot:cookie-in
"session-token")))
636 (let* ((session-token (base64:base64-string-to-usb8-array session-token
))
637 (csrf-token (base64:base64-string-to-usb8-array csrf-token
))
638 (correct-token (nth-value 1 (make-csrf-token session-token
(subseq csrf-token
0 16)))))
639 (assert (ironclad:constant-time-equal csrf-token correct-token
) nil
"CSRF check failed.")
642 (defun generate-css-link ()
643 (labels ((gen-inner (theme os
)
644 (generate-versioned-link (format nil
"/css/style~@[-~A~].~A.css" (if (and theme
(> (length theme
) 0)) theme
) os
))))
645 (let* ((ua (hunchentoot:header-in
* :user-agent
))
646 (theme (hunchentoot:cookie-in
"theme"))
647 (os (cond ((search "Windows" ua
) "windows")
648 ((search "Mac OS" ua
) "mac")
650 (handler-case (gen-inner theme os
)
651 (serious-condition () (gen-inner nil os
))))))
653 (defun html-body (out-stream fn
&key title description current-uri content-class robots
)
654 (let* ((session-token (hunchentoot:cookie-in
"session-token"))
655 (csrf-token (and session-token
(make-csrf-token session-token
))))
656 (format out-stream
"<!DOCTYPE html><html lang=\"en-US\"><head>")
657 (format out-stream
"<script>window.GW = { }; loggedInUserId=\"~A\"; loggedInUserDisplayName=\"~A\"; loggedInUserSlug=\"~A\"; ~@[GW.csrfToken=\"~A\"; ~]~A</script>~A"
658 (or (logged-in-userid) "")
659 (or (logged-in-username) "")
660 (or (logged-in-user-slug) "")
662 (load-time-value (with-open-file (s "www/head.js") (uiop:slurp-stream-string s
)) t
)
663 *extra-inline-scripts
*)
664 (format out-stream
"~A<link rel=\"stylesheet\" href=\"~A\">~{<link rel=\"stylesheet\" href=\"~A\">~}<link rel=\"shortcut icon\" href=\"~A\">"
667 (generate-fonts-links)
668 (generate-versioned-link "/assets/favicon.ico"))
669 (format out-stream
"<script src=\"~A\" async></script>~A"
670 (generate-versioned-link "/script.js")
671 *extra-external-scripts
*)
672 (format out-stream
"<title>~@[~A - ~]~A</title>~@[<meta name=\"description\" content=\"~A\">~]~@[<meta name=\"robots\" content=\"~A\">~]"
673 (if title
(encode-entities title
))
674 (site-title *current-site
*)
677 (format out-stream
"</head>"))
680 (format out-stream
"<body><div id=\"content\"~@[ class=\"~A\"~]>"
682 (nav-bar-to-html out-stream
(or current-uri
(replace-query-params (hunchentoot:request-uri
*) "offset" nil
"sort" nil
)))
683 (force-output out-stream
)
685 (format out-stream
"</div></body></html>")))
687 (defun replace-query-params (uri &rest params
)
688 (let* ((quri (quri:uri uri
))
689 (old-params (quri:uri-query-params quri
))
690 (new-params (loop with out
= old-params
691 for
(param value
) on params by
#'cddr
693 (alexandria:if-let
(old-cons (assoc param out
:test
#'equal
))
694 (setf (cdr old-cons
) value
)
695 (setf out
(nconc out
(list (cons param value
)))))
696 (setf out
(remove-if (lambda (x) (equal (car x
) param
)) out
)))
697 finally
(return out
))))
699 (setf (quri:uri-query-params quri
) new-params
)
700 (setf (quri:uri-query quri
) nil
))
701 (quri:render-uri quri
)))
703 (defun pagination-nav-bars (&key offset total with-next
(items-per-page (user-pref :items-per-page
)))
704 (lambda (out-stream fn
)
705 (labels ((pages-to-end (n) (< (+ offset
(* items-per-page n
)) total
)))
706 (let* ((with-next (if total
(pages-to-end 1) with-next
))
707 (next (if (and offset with-next
) (+ offset items-per-page
)))
708 (prev (if (and offset
(>= offset items-per-page
)) (- offset items-per-page
)))
709 (request-uri (hunchentoot:request-uri
*))
710 (first-uri (if (and prev
(> prev
0)) (replace-query-params request-uri
"offset" nil
)))
711 (prev-uri (if prev
(replace-query-params request-uri
"offset" (if (= prev
0) nil prev
))))
712 (next-uri (if next
(replace-query-params request-uri
"offset" next
)))
713 (last-uri (if (and total offset
(pages-to-end 2))
714 (replace-query-params request-uri
"offset" (- total
(mod (- total
1) items-per-page
) 1)))))
715 (if (or next prev last-uri
)
716 (labels ((write-item (uri class title accesskey
)
717 (format out-stream
"<a href=\"~A\" class=\"button nav-item-~A~:[ disabled~;~]\" title=\"~A [~A]\" accesskey=\"~A\"></a>"
718 (or uri
"#") class uri title accesskey accesskey
)))
719 (format out-stream
"<div id='top-nav-bar'>")
720 (write-item first-uri
"first" "First page" "\\")
721 (write-item prev-uri
"prev" "Previous page" "[")
722 (format out-stream
"<span class='page-number'><span class='page-number-label'>Page</span> ~A</span>" (+ 1 (/ (or offset
0) items-per-page
)))
723 (write-item next-uri
"next" "Next page" "]")
724 (write-item last-uri
"last" "Last page" "/")
725 (format out-stream
"</div>")))
727 (nav-bar-outer out-stream nil
(list :bottom-bar
729 (first-uri `("first" ,first-uri
"Back to first"))
730 (prev-uri `("prev" ,prev-uri
"Previous" :nofollow t
))
731 (t `("top" "#top" "Back to top"))
732 (next-uri `("next" ,next-uri
"Next" :nofollow t
))
733 (last-uri `("last" ,last-uri
"Last" :nofollow t
)))))
734 (format out-stream
"<script>document.querySelectorAll('#bottom-bar').forEach(bb => { bb.classList.add('decorative'); });</script>")))))
736 (defun map-output (out-stream fn list
)
737 (loop for item in list do
(write-string (funcall fn item
) out-stream
)))
739 (defmacro with-outputs
((out-stream) &body body
)
740 (alexandria:with-gensyms
(stream-sym)
741 (let ((out-body (map 'list
(lambda (x) `(princ ,x
,stream-sym
)) body
)))
742 `(let ((,stream-sym
,out-stream
))
745 (defun call-with-emit-page (out-stream fn
&key title description current-uri content-class
(return-code 200) robots
(pagination (pagination-nav-bars)) top-nav
)
746 (declare (ignore return-code
))
749 (html-body out-stream
751 (when top-nav
(funcall top-nav out-stream
))
752 (funcall pagination out-stream fn
))
753 :title title
:description description
:current-uri current-uri
:content-class content-class
:robots robots
)
754 (force-output out-stream
))))
756 (defun set-cookie (key value
&key
(max-age (- (expt 2 31) 1)) (path "/"))
757 (hunchentoot:set-cookie key
:value value
:path path
:max-age max-age
:secure
(site-secure *current-site
*)))
759 (defun set-default-headers (return-code)
760 (let ((push-option (if (hunchentoot:cookie-in
"push") '("nopush"))))
761 (setf (hunchentoot:content-type
*) "text/html; charset=utf-8"
762 (hunchentoot:return-code
*) return-code
763 (hunchentoot:header-out
:link
) (format nil
"~:{<~A>;rel=preload;type=~A;as=~A~@{;~A~}~:^,~}"
764 `((,(generate-css-link) "text/css" "style" ,.push-option
)
765 ,.
(loop for link in
(generate-fonts-links)
766 collect
(list* link
"text/css" "style" push-option
))
767 (,(generate-versioned-link "/script.js") "text/javascript" "script" ,.push-option
))))
768 (unless push-option
(set-cookie "push" "t" :max-age
(* 4 60 60)))))
770 (defun user-pref (key)
771 (or (cdr (assoc key
*current-prefs
*))
772 (cdr (assoc key
*default-prefs
*))))
774 (defun set-user-pref (key value
)
775 (assert (boundp 'hunchentoot
:*reply
*))
776 (setf *current-prefs
* (remove-duplicates (acons key value
*current-prefs
*) :key
#'car
:from-end t
))
777 (set-cookie "prefs" (quri:url-encode
(json:encode-json-to-string
*current-prefs
*))))
779 (defmacro with-response-stream
((out-stream) &body body
) `(call-with-response-stream (lambda (,out-stream
) ,.body
)))
781 (defun call-with-response-stream (fn)
782 (let ((*html-output
* (make-flexi-stream (hunchentoot:send-headers
) :external-format
:utf-8
)))
783 (funcall fn
*html-output
*)))
785 (defmacro emit-page
((out-stream &rest args
&key
(return-code 200) &allow-other-keys
) &body body
)
786 (alexandria:once-only
(return-code)
788 (set-default-headers ,return-code
)
789 (with-response-stream (,out-stream
)
790 (call-with-emit-page ,out-stream
794 (defun call-with-error-page (fn)
796 (alexandria:if-let
(status-string (hunchentoot:cookie-in
"lw2-status"))
797 (if (string= status-string
"") nil
798 (let ((json:*identifier-name-to-key
* #'json
:safe-json-intern
))
799 (json:decode-json-from-string status-string
)))))
801 (alexandria:if-let
(prefs-string (hunchentoot:cookie-in
"prefs"))
802 (let ((json:*identifier-name-to-key
* 'json
:safe-json-intern
))
803 (ignore-errors (json:decode-json-from-string
(quri:url-decode prefs-string
)))))))
804 (with-site-context ((let ((host (or (hunchentoot:header-in
* :x-forwarded-host
) (hunchentoot:header-in
* :host
))))
806 (error "Unknown site: ~A" host
))))
807 (multiple-value-bind (*current-auth-token
* *current-userid
* *current-username
*)
813 (at (hunchentoot:cookie-in
"lw2-auth-token"))
814 (if (or (string= at
"") (not lw2-status
) (> (get-unix-time) (- (cdr (assoc :expires lw2-status
)) (* 60 60 24))))
816 (with-cache-readonly-transaction
819 (cache-get "auth-token-to-userid" auth-token
)
820 (cache-get "auth-token-to-username" auth-token
)))))
821 (let ((*current-user-slug
* (and *current-userid
* (get-user-slug *current-userid
*))))
825 (serious-condition (condition)
826 (emit-page (out-stream :title
"Error" :return-code
(condition-http-return-code condition
) :content-class
"error-page")
827 (error-to-html out-stream condition
)))))))))
829 (defmacro with-error-page
(&body body
)
830 `(call-with-error-page (lambda () ,@body
)))
832 (defun output-form (out-stream method action id heading csrf-token fields button-label
&key textarea end-html
)
833 (format out-stream
"<form method=\"~A\" action=\"~A\" id=\"~A\"><h1>~A</h1>" method action id heading
)
834 (loop for
(id label type . params
) in fields
835 do
(format out-stream
"<label for=\"~A\">~A:</label>" id label
)
837 ((string= type
"select")
838 (destructuring-bind (option-list &optional default
) params
839 (format out-stream
"<select name=\"~A\">" id
)
840 (loop for
(value label
) in option-list
841 do
(format out-stream
"<option value=\"~A\"~:[~; selected~]>~A</option>" value
(string= default value
) label
))
842 (format out-stream
"</select>")))
844 (destructuring-bind (&optional
(autocomplete "off") default
) params
845 (format out-stream
"<input type=\"~A\" name=\"~A\" autocomplete=\"~A\"~@[ value=\"~A\"~]>" type id autocomplete
(and default
(encode-entities default
))))))
846 do
(format out-stream
""))
848 (destructuring-bind (ta-name ta-contents
) textarea
849 (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
))))
850 (format out-stream
"<input type=\"hidden\" name=\"csrf-token\" value=\"~A\"><input type=\"submit\" value=\"~A\">~@[~A~]</form>"
851 csrf-token button-label end-html
))
853 (defun page-toolbar-to-html (out-stream &key title new-post new-conversation logout
(rss t
))
854 (let ((liu (logged-in-userid)))
855 (format out-stream
"<div class=\"page-toolbar\">")
857 (format out-stream
"<form method=\"post\" action=\"/logout\"><button class=\"logout-button button\" name=\"logout\" value=\"~A\">Log out</button></form>"
859 (when (and new-conversation liu
)
860 (multiple-value-bind (text to
)
861 (typecase new-conversation
(string (values "Send private message" new-conversation
)) (t "New conversation"))
862 (format out-stream
"<a class=\"new-private-message button\" href=\"/conversation~@[?to=~A~]\">~A</a>"
864 (when (and new-post liu
)
865 (format out-stream
"<a class=\"new-post button\" href=\"/edit-post~@[?section=~A~]\" accesskey=\"n\" title=\"Create new post [n]\">New post</a>"
866 (typecase new-post
(string new-post
) (t nil
))))
867 (when (and title rss
)
868 (format out-stream
"<a class=\"rss\" rel=\"alternate\" type=\"application/rss+xml\" title=\"~A RSS feed\" href=\"~A\">RSS</a>"
869 title
(replace-query-params (hunchentoot:request-uri
*) "offset" nil
"format" "rss")))
870 (format out-stream
"</div>")))
872 (defun view-items-index (items &key section title current-uri hide-title need-auth
(pagination (pagination-nav-bars)) (top-nav (lambda (s) (page-toolbar-to-html s
:title title
))) (content-class "index-page"))
873 (alexandria:switch
((hunchentoot:get-parameter
"format") :test
#'string
=)
875 (setf (hunchentoot:content-type
*) "application/rss+xml; charset=utf-8")
876 (with-response-stream (out-stream)
877 (write-index-items-to-rss out-stream items
:title title
)))
879 (emit-page (out-stream :title
(if hide-title nil title
) :description
(site-description *current-site
*) :content-class content-class
880 :current-uri current-uri
:robots
(if (hunchentoot:get-parameter
:offset
) "noindex, nofollow")
881 :pagination pagination
:top-nav top-nav
)
882 (write-index-items-to-html out-stream items
884 :skip-section section
)))))
886 (defun link-if-not (stream linkp url class text
&key accesskey nofollow
)
887 (declare (dynamic-extent linkp url text
))
889 (format stream
"<a href=\"~A\" class=\"~A\"~@[ accesskey=\"~A\"~]~:[~; rel=\"nofollow\"~]>~A</a>" url class accesskey nofollow text
)
890 (format stream
"<span class=\"~A\">~A</span>" class text
)))
892 (defun postprocess-markdown (markdown)
893 (ppcre:regex-replace-all
(concatenate 'string
(ppcre:regex-replace-all
"\\." (site-uri *current-site
*) "\\.") "posts/([^/ ]{17})/([^/# ]*)(?:#comment-([^/ ]{17})|/comment/([^/ ]{17}))?")
895 (lambda (target-string start end match-start match-end reg-starts reg-ends
)
896 (declare (ignore start end match-start match-end
))
897 (labels ((reg (n) (if (and (> (length reg-starts
) n
) (aref reg-starts n
))
898 (substring target-string
(aref reg-starts n
) (aref reg-ends n
)))))
899 (format nil
"https://www.lesswrong.com/posts/~A/~A~@[#~A~]" (reg 0) (reg 1) (or (reg 2) (reg 3)))))))
901 (defun post-or-get-parameter (name)
902 (or (hunchentoot:post-parameter name
) (hunchentoot:get-parameter name
)))
904 (defun redirect (uri &key
(type :see-other
))
905 (setf (hunchentoot:return-code
*) (ecase type
(:see-other
303) (:permanent
301))
906 (hunchentoot:header-out
"Location") uri
))
908 (defmacro ignorable-multiple-value-bind
((&rest bindings
) value-form
&body body
)
909 (let (new-bindings ignores
)
910 (dolist (binding (reverse bindings
))
912 (let ((gensym (gensym)))
913 (push gensym new-bindings
)
914 (push gensym ignores
))
915 (push binding new-bindings
)))
916 `(multiple-value-bind ,new-bindings
,value-form
917 (declare (ignore ,.ignores
))
920 (defmacro define-page
(name path-specifier additional-vars
&body body
)
921 (labels ((make-lambda (args)
923 collect
(if (atom a
) a
(first a
))))
924 (filter-plist (plist &rest args
)
925 (declare (dynamic-extent args
))
926 (map-plist (lambda (key val
) (when (member key args
) (list key val
))) plist
))
927 (make-hunchentoot-lambda (args)
929 collect
(if (atom x
) x
930 (cons (first x
) (filter-plist (rest x
) :request-type
:real-name
)))))
931 (make-binding-form (additional-vars body
&aux var-bindings additional-declarations additional-preamble
)
932 (loop for x in additional-vars
935 (destructuring-bind (name &key member type default required request-type real-name
) (if (atom x
) (list x
) x
)
936 (declare (ignore request-type real-name
))
940 `(let ((sym (find-symbol (string-upcase ,name
) ,(find-package '#:keyword
))))
941 (if (member sym
(quote ,member
)) sym
)))
942 ((and type
(subtypep type
'integer
))
943 `(if ,name
(parse-integer ,name
)))))
946 `(or ,inner-form
,default
)
949 (push `(unless (and ,name
(not (equal ,name
""))) (error "Missing required parameter: ~A" (quote ,name
)))
950 additional-preamble
))
952 (if type
(error "Cannot specify both member and type.")
953 (push `(type (or null symbol
) ,name
) additional-declarations
))
955 (push `(type (or null
,type
) ,name
) additional-declarations
)
956 (push `(type (or null simple-string
) ,name
) additional-declarations
)))
958 (push `(,name
,inner-form
) var-bindings
)))))
959 `(let ,var-bindings
(declare ,@additional-declarations
) ,@additional-preamble
,@body
)))
960 (multiple-value-bind (path-specifier-form path-bindings-wrapper specifier-vars
)
961 (if (stringp path-specifier
)
962 (values path-specifier
#'identity
)
963 (destructuring-bind (specifier-type specifier-body
&rest specifier-args
) path-specifier
964 (ecase specifier-type
966 (values `(lambda (r) (funcall ,specifier-body
(hunchentoot:request-uri r
)))
968 (lambda (body) `(ignorable-multiple-value-bind ,(make-lambda specifier-args
) (funcall ,specifier-body
(hunchentoot:request-uri
*)) ,body
))
972 (let ((fn `(lambda (r) (ppcre:scan-to-strings
,specifier-body
(hunchentoot:request-uri r
)))))
975 (alexandria:with-gensyms
(result-vector)
976 `(let ((,result-vector
(nth-value 1 (funcall ,fn hunchentoot
:*request
*))))
977 (declare (type simple-vector
,result-vector
))
979 ,(loop for v in
(make-lambda specifier-args
) as x from
0 collecting
`(,v
(if (> (length ,result-vector
) ,x
) (aref ,result-vector
,x
))))
982 (let* ((rewritten-body
983 (if (eq (ignore-errors (caar body
)) 'request-method
)
985 (unless (= (length body
) 1)
986 (error "REQUEST-METHOD must be the only form when it appears in DEFINE-PAGE."))
987 `((ecase (hunchentoot:request-method
*)
988 ,.
(loop for method-body in
(cdar body
)
989 collect
(destructuring-bind (method args
&body inner-body
) method-body
990 (unless (eq method
:get
)
991 (alexandria:with-gensyms
(csrf-token)
992 (push `(,csrf-token
:real-name
"csrf-token" :required t
) args
)
993 (push `(check-csrf-token ,csrf-token
) inner-body
)))
995 do
(push (append (if (atom a
) (list a
) (cons (first a
) (filter-plist (rest a
) :real-name
))) (list :request-type method
)) additional-vars
))
996 `(,method
,(make-binding-form args inner-body
)))))))
998 `(hunchentoot:define-easy-handler
(,name
:uri
,path-specifier-form
) ,(make-hunchentoot-lambda additional-vars
)
1001 ,(funcall path-bindings-wrapper
1002 (make-binding-form (append specifier-vars additional-vars
)
1003 rewritten-body
)))))))))
1005 (define-component sort-widget
(&key
(sort-options '(:new
:hot
)) (pref :default-sort
) (param-name "sort") (html-class "sort"))
1006 (:http-args
'((sort :alias param-name
:member sort-options
)))
1007 (let ((sort-string (if sort
(string-downcase sort
))))
1009 (set-user-pref :default-sort sort-string
))
1010 (renderer (out-stream)
1011 (sublevel-nav-to-html out-stream
1014 :param-name param-name
1015 :extra-class html-class
))
1016 (or sort-string
(user-pref pref
))))
1018 (define-page view-root
"/" ((offset :type fixnum
)
1019 (limit :type fixnum
))
1020 (component-value-bind ((sort-string sort-widget
))
1021 (multiple-value-bind (posts total
)
1022 (get-posts-index :offset offset
:limit
(or limit
(user-pref :items-per-page
)) :sort sort-string
)
1023 (view-items-index posts
1024 :section
:frontpage
:title
"Frontpage posts" :hide-title t
1025 :pagination
(pagination-nav-bars :offset
(or offset
0) :total total
:with-next
(not total
))
1026 :top-nav
(lambda (out-stream)
1027 (page-toolbar-to-html out-stream
1028 :title
"Frontpage posts"
1030 (funcall sort-widget out-stream
))))))
1032 (define-page view-index
"/index" ((view :member
(:all
:new
:frontpage
:featured
:meta
:community
:alignment-forum
:questions
) :default
:all
)
1034 (offset :type fixnum
)
1035 (limit :type fixnum
))
1036 (when (eq view
:new
) (redirect (replace-query-params (hunchentoot:request-uri
*) "view" "all" "all" nil
) :type
:permanent
) (return))
1037 (component-value-bind ((sort-string sort-widget
))
1038 (multiple-value-bind (posts total
)
1039 (get-posts-index :view
(string-downcase view
) :before before
:after after
:offset offset
:limit
(or limit
(user-pref :items-per-page
)) :sort sort-string
)
1040 (let ((page-title (format nil
"~@(~A posts~)" view
)))
1041 (view-items-index posts
1042 :section view
:title page-title
1043 :pagination
(pagination-nav-bars :offset
(or offset
0) :total total
:with-next
(not total
))
1044 :content-class
(format nil
"index-page ~(~A~)-index-page" view
)
1045 :top-nav
(lambda (out-stream)
1046 (page-toolbar-to-html out-stream
1048 :new-post
(if (eq view
:meta
) "meta" t
))
1049 (if (member view
'(:all
))
1050 (funcall sort-widget out-stream
))))))))
1052 (define-page view-post
"/post" ((id :required t
))
1053 (redirect (generate-post-link id
) :type
:permanent
))
1055 (define-page view-post-lw1-link
(:function
#'match-lw1-link
) ()
1056 (redirect (convert-lw1-link (hunchentoot:request-uri
*)) :type
:permanent
))
1058 (define-page view-post-lw2-slug-link
(:function
#'match-lw2-slug-link
) ()
1059 (redirect (convert-lw2-slug-link (hunchentoot:request-uri
*)) :type
:see-other
))
1061 (define-page view-post-lw2-sequence-link
(:function
#'match-lw2-sequence-link
) ()
1062 (redirect (convert-lw2-sequence-link (hunchentoot:request-uri
*)) :type
:see-other
))
1064 (define-page view-feed
"/feed" ()
1065 (redirect "/?format=rss" :type
:permanent
))
1067 (define-page view-post-lw2-link
(:function
#'match-lw2-link post-id comment-id
* comment-link-type
) (need-auth chrono
)
1070 (let ((lw2-auth-token *current-auth-token
*))
1071 (labels ((output-comments (out-stream id comments target
)
1072 (format out-stream
"<div id=\"~A\" class=\"comments\">" id
)
1073 (with-error-html-block (out-stream)
1075 (comment-thread-to-html out-stream
1077 (comment-item-to-html
1080 :extra-html-fn
(lambda (c-id)
1081 (let ((*comment-individual-link
* nil
))
1082 (comment-tree-to-html out-stream
(make-comment-parent-hash comments
) c-id
))))))
1085 (comment-chrono-to-html out-stream comments
)
1086 (comment-tree-to-html out-stream
(make-comment-parent-hash comments
)))
1087 <div class
="comments-empty-message">(if (string= id
"answers") "No answers." "No comments.")</div
>)))
1088 (format out-stream
"</div>"))
1089 (output-comments-votes (out-stream)
1091 (when lw2-auth-token
1092 (format out-stream
"<script>commentVotes=~A</script>"
1093 (json:encode-json-to-string
(get-post-comments-votes post-id lw2-auth-token
))))
1095 (output-post-vote (out-stream)
1097 (format out-stream
"<script>postVote=~A</script>"
1098 (json:encode-json-to-string
(get-post-vote post-id lw2-auth-token
)))
1100 (multiple-value-bind (post title condition
)
1101 (handler-case (nth-value 0 (get-post-body post-id
:auth-token
(and need-auth lw2-auth-token
)))
1102 (serious-condition (c) (values nil
"Error" c
))
1103 (:no-error
(post) (values post
(cdr (assoc :title post
)) nil
)))
1105 (let* ((*comment-individual-link
* t
)
1106 (comment-thread-type (if (string= comment-link-type
"answer") :answer
:comment
))
1107 (comments (case comment-thread-type
1108 (:comment
(get-post-comments post-id
))
1109 (:answer
(get-post-answers post-id
))))
1110 (target-comment (find comment-id comments
:key
(lambda (c) (cdr (assoc :--id c
))) :test
#'string
=))
1111 (display-name (get-username (cdr (assoc :user-id target-comment
))))
1113 ((and (eq comment-thread-type
:answer
)
1114 (not (cdr (assoc :parent-comment-id target-comment
))))
1116 (t "comments on"))))
1117 (emit-page (out-stream :title
(format nil
"~A ~A ~A" display-name verb-phrase title
)
1118 :content-class
"individual-thread-page comment-thread-page")
1119 (format out-stream
"<h1 class=\"post-title\">~A ~A <a href=\"~A\">~A</a></h1>"
1120 (encode-entities display-name
)
1122 (generate-post-link post-id
)
1123 (clean-text-to-html title
:hyphenation nil
))
1124 (output-comments out-stream
"comments" comments target-comment
)
1125 (when lw2-auth-token
1126 (force-output out-stream
)
1127 (output-comments-votes out-stream
))))
1128 (emit-page (out-stream :title title
:content-class
(format nil
"post-page comment-thread-page~:[~; question-post-page~]" (cdr (assoc :question post
))))
1131 (error-to-html out-stream condition
))
1133 (post-body-to-html post
)))
1134 (when (and lw2-auth-token
(equal (logged-in-userid) (cdr (assoc :user-id post
))))
1135 (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>"
1136 (cdr (assoc :--id post
))))
1137 (force-output out-stream
)
1139 (let* ((question (cdr (assoc :question post
)))
1140 (answers (when question
1141 (get-post-answers post-id
)))
1142 (comments (get-post-comments post-id
)))
1144 (output-comments out-stream
"answers" answers nil
))
1145 (output-comments out-stream
"comments" comments nil
))
1146 (serious-condition (c) (error-to-html out-stream c
)))
1147 (when lw2-auth-token
1148 (force-output out-stream
)
1149 (output-post-vote out-stream
)
1150 (output-comments-votes out-stream
))))))))
1151 (:post
(csrf-token text answer parent-answer-id parent-comment-id edit-comment-id retract-comment-id unretract-comment-id delete-comment-id
)
1152 (let ((lw2-auth-token *current-auth-token
*))
1153 (check-csrf-token csrf-token
)
1154 (assert lw2-auth-token
)
1155 (let ((question (cdr (assoc :question
(get-post-body post-id
:auth-token lw2-auth-token
))))
1161 (t :body
(postprocess-markdown text
))
1162 (t :last-edited-as
"markdown")
1163 ((not edit-comment-id
) :post-id post-id
)
1164 (parent-comment-id :parent-comment-id parent-comment-id
)
1166 (parent-answer-id :parent-answer-id parent-answer-id
))))
1168 (prog1 edit-comment-id
1169 (do-lw2-comment-edit lw2-auth-token edit-comment-id comment-data
))
1170 (do-lw2-comment lw2-auth-token comment-data
))))
1172 (do-lw2-comment-edit lw2-auth-token retract-comment-id
'((:retracted . t
))))
1173 (unretract-comment-id
1174 (do-lw2-comment-edit lw2-auth-token unretract-comment-id
'((:retracted . nil
))))
1176 (do-lw2-comment-edit lw2-auth-token delete-comment-id
'((:deleted . t
) (:deleted-public . t
)
1177 (:deleted-reason .
"Comment deleted by its author.")))
1180 (get-post-comments post-id
:force-revalidate t
)
1182 (get-post-answers post-id
:force-revalidate t
)))
1184 (cache-put "comment-markdown-source" new-comment-id text
)
1185 (redirect (generate-post-link (match-lw2-link (hunchentoot:request-uri
*)) new-comment-id
))))))))
1187 (defparameter *edit-post-template
* (compile-template* "edit-post.html"))
1189 (define-page view-edit-post
"/edit-post" (title url section post-id link-post
)
1192 (let* ((csrf-token (make-csrf-token))
1193 (post-body (if post-id
(get-post-body post-id
:auth-token
(hunchentoot:cookie-in
"lw2-auth-token"))))
1194 (section (or section
(loop for
(sym . sec
) in
'((:draft .
"drafts") (:meta .
"meta") (:frontpage-date .
"frontpage"))
1195 if
(cdr (assoc sym post-body
)) return sec
1196 finally
(return "all")))))
1197 (emit-page (out-stream :title
(if post-id
"Edit Post" "New Post") :content-class
"edit-post-page")
1198 (render-template* *edit-post-template
* out-stream
1199 :csrf-token csrf-token
1200 :title
(cdr (assoc :title post-body
))
1201 :url
(cdr (assoc :url post-body
))
1202 :question
(cdr (assoc :question post-body
))
1204 :section-list
(loop for
(name desc
) in
'(("all" "All") ("meta" "Meta") ("drafts" "Drafts"))
1205 collect
(alist :name name
:desc desc
:selected
(string= name section
)))
1206 :markdown-source
(or (and post-id
(cache-get "post-markdown-source" post-id
)) (cdr (assoc :html-body post-body
)) "")))))
1207 (:post
(text question
)
1208 (let ((lw2-auth-token *current-auth-token
*)
1209 (url (if (string= url
"") nil url
)))
1210 (assert lw2-auth-token
)
1213 (t :body
(postprocess-markdown text
))
1215 (t :last-edited-as
"markdown")
1216 (t :url
(if link-post url
))
1217 (t :meta
(string= section
"meta"))
1218 (t :draft
(string= section
"drafts"))
1219 ((not post-id
) :question
(and question t
))))
1220 (post-set (loop for item in post-data when
(cdr item
) collect item
))
1221 (post-unset (loop for item in post-data when
(not (cdr item
)) collect
(cons (car item
) t
))))
1222 (let* ((new-post-data
1224 (do-lw2-post-edit lw2-auth-token post-id post-set post-unset
)
1225 (do-lw2-post lw2-auth-token post-set
)))
1226 (new-post-id (cdr (assoc :--id new-post-data
))))
1227 (assert new-post-id
)
1228 (cache-put "post-markdown-source" new-post-id text
)
1229 (ignore-errors (get-post-body post-id
:force-revalidate t
))
1230 (redirect (if (cdr (assoc "draft" post-data
:test
#'equal
))
1231 (concatenate 'string
(generate-post-link new-post-data
) "?need-auth=y")
1232 (generate-post-link new-post-data
)))))))))
1234 (hunchentoot:define-easy-handler
(view-karma-vote :uri
"/karma-vote") ((csrf-token :request-type
:post
) (target :request-type
:post
) (target-type :request-type
:post
) (vote-type :request-type
:post
))
1236 (check-csrf-token csrf-token
)
1237 (let ((lw2-auth-token (hunchentoot:cookie-in
"lw2-auth-token")))
1238 (multiple-value-bind (points vote-type
) (do-lw2-vote lw2-auth-token target target-type vote-type
)
1239 (json:encode-json-to-string
(list (pretty-number points
"point") vote-type
))))))
1241 (hunchentoot:define-easy-handler
(view-check-notifications :uri
"/check-notifications") ()
1243 (if *current-auth-token
*
1244 (let ((notifications-status (check-notifications (logged-in-userid) *current-auth-token
*)))
1245 (json:encode-json-to-string notifications-status
)))))
1247 (define-page view-recent-comments
"/recentcomments" ((offset :type fixnum
)
1248 (limit :type fixnum
))
1249 (let ((want-total (not (typep *current-backend
* 'backend-lw2
)))) ; jumping to last page causes LW2 to explode
1250 (multiple-value-bind (recent-comments total
)
1251 (if (or offset limit
(/= (user-pref :items-per-page
) 20))
1252 (lw2-graphql-query (lw2-query-string :comment
:list
1253 (remove nil
(alist :view
"postCommentsNew" :limit
(or limit
(user-pref :items-per-page
)) :offset offset
)
1255 (comments-index-fields)
1256 :with-total want-total
))
1257 (get-recent-comments :with-total want-total
))
1258 (view-items-index recent-comments
:title
"Recent comments" :pagination
(pagination-nav-bars :offset
(or offset
0) :with-next
(not want-total
) :total
(if want-total total
))))))
1260 (define-page view-user
(:regex
"^/users/(.*?)(?:$|\\?)|^/user" user-slug
) (id
1261 (offset :type fixnum
:default
0)
1262 (show :member
(:all
:posts
:comments
:drafts
:conversations
:inbox
) :default
:all
)
1263 (sort :member
(:top
:new
) :default
:new
))
1264 (let* ((auth-token (if (eq show
:inbox
) *current-auth-token
*))
1265 (user-query-terms (cond
1266 (user-slug (alist :slug user-slug
))
1267 (id (alist :document-id id
))))
1269 (let ((ui (lw2-graphql-query (lw2-query-string :user
:single user-query-terms
`(:--id
:slug
:display-name
:karma
,@(if (eq show
:inbox
) '(:last-notifications-check
))))
1270 :auth-token auth-token
)))
1271 (if (cdr (assoc :--id ui
))
1273 (error (make-condition 'lw2-user-not-found-error
)))))
1274 (user-id (cdr (assoc :--id user-info
)))
1275 (own-user-page (logged-in-userid user-id
))
1276 (comments-index-fields (remove :page-url
(comments-index-fields))) ; page-url sometimes causes "Cannot read property '_id' of undefined" error
1277 (display-name (if user-slug
(cdr (assoc :display-name user-info
)) user-id
))
1278 (show-text (if (not (eq show
:all
)) (string-capitalize show
)))
1279 (title (format nil
"~A~@['s ~A~]" display-name show-text
))
1280 (sort-type (case sort
(:top
:score
) (:new
:date
)))
1281 (comments-base-terms (ecase sort-type
(:score
(load-time-value (alist :view
"postCommentsTop"))) (:date
(load-time-value (alist :view
"allRecentComments"))))))
1282 (multiple-value-bind (items total
)
1285 (get-user-posts user-id
:offset offset
:limit
(+ 1 (user-pref :items-per-page
)) :sort-type sort-type
))
1287 (lw2-graphql-query (lw2-query-string :comment
:list
1288 (nconc (alist :offset offset
:limit
(+ 1 (user-pref :items-per-page
)) :user-id user-id
)
1289 comments-base-terms
)
1290 comments-index-fields
)))
1292 (get-user-posts user-id
:drafts t
:auth-token
(hunchentoot:cookie-in
"lw2-auth-token")))
1294 (let ((conversations
1295 (lw2-graphql-query (lw2-query-string :conversation
:list
1296 (alist :view
"userConversations" :limit
(+ 1 (user-pref :items-per-page
)) :offset offset
:user-id user-id
)
1297 '(:--id
:created-at
:title
(:participants
:display-name
:slug
) :----typename
))
1298 :auth-token
(hunchentoot:cookie-in
"lw2-auth-token"))))
1299 (lw2-graphql-query-map
1301 (lw2-query-string* :message
:total
(alist :view
"messagesConversation" :conversation-id
(cdr (assoc :--id c
))) nil
))
1303 :postprocess
(lambda (c result
)
1304 (acons :messages-total result c
))
1305 :auth-token
(hunchentoot:cookie-in
"lw2-auth-token"))))
1308 (let ((notifications (get-notifications :user-id user-id
:offset offset
:auth-token
(hunchentoot:cookie-in
"lw2-auth-token")))
1309 (last-check (ignore-errors (local-time:parse-timestring
(cdr (assoc :last-notifications-check user-info
))))))
1310 (labels ((check-new (key obj
)
1311 (if (ignore-errors (local-time:timestamp
< last-check
(local-time:parse-timestring
(cdr (assoc key obj
)))))
1312 (acons :highlight-new t obj
)
1314 (lw2-graphql-query-map
1316 (alexandria:switch
((cdr (assoc :document-type n
)) :test
#'string
=)
1318 (lw2-query-string* :comment
:single
1319 (alist :document-id
(cdr (assoc :document-id n
)))
1320 (comments-index-fields)))
1322 (lw2-query-string* :post
:single
(alist :document-id
(cdr (assoc :document-id n
)))
1323 (posts-index-fields)))
1325 (lw2-query-string* :message
:single
(alist :document-id
(cdr (assoc :document-id n
)))
1326 *messages-index-fields
*))
1330 :postprocess
(lambda (n result
)
1333 (alexandria:switch
((cdr (assoc :document-type n
)) :test
#'string
=)
1334 ("comment" :posted-at
)
1336 ("message" :created-at
))
1339 :auth-token auth-token
)))
1341 (hunchentoot:cookie-in
"lw2-auth-token")
1343 (alist :last-notifications-check
1344 (local-time:format-timestring nil
(local-time:now
)
1345 :format lw2.graphql
:+graphql-timestamp-format
+
1346 :timezone local-time
:+utc-zone
+)))))
1348 (let ((user-posts (get-user-posts user-id
:limit
(+ 1 (user-pref :items-per-page
) offset
)))
1349 (user-comments (lw2-graphql-query (lw2-query-string :comment
:list
(nconc (alist :limit
(+ 1 (user-pref :items-per-page
) offset
) :user-id user-id
) comments-base-terms
)
1350 comments-index-fields
))))
1351 (concatenate 'list user-posts user-comments
))))
1352 (let ((with-next (> (length items
) (+ (if (eq show
:all
) offset
0) (user-pref :items-per-page
))))
1353 (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
1354 (view-items-index interleave
:title title
1355 :content-class
(format nil
"user-page~@[ ~A-user-page~]~:[~; own-user-page~]" show-text own-user-page
)
1356 :current-uri
(format nil
"/users/~A" user-slug
)
1358 :pagination
(pagination-nav-bars :offset offset
:total total
:with-next
(if (not total
) with-next
))
1359 :need-auth
(eq show
:drafts
) :section
(if (eq show
:drafts
) "drafts" nil
)
1360 :top-nav
(lambda (out-stream)
1361 (page-toolbar-to-html out-stream
1363 :rss
(not (member show
'(:drafts
:conversations
:inbox
)))
1364 :new-post
(if (eq show
:drafts
) "drafts" t
)
1365 :new-conversation
(if own-user-page t user-slug
)
1366 :logout own-user-page
)
1367 (format out-stream
"<h1 class=\"page-main-heading\"~@[ ~A~]>~A</h1><div class=\"user-stats\">Karma: <span class=\"karma-total\">~A</span></div>"
1368 (if (not own-user-page
)
1370 (format nil
"data-anti-kibitzer-redirect=\"/user?id=~A\"" (cdr (assoc :--id user-info
)))
1371 (format nil
"data-kibitzer-redirect=\"/users/~A\"" (cdr (assoc :slug user-info
)))))
1372 (encode-entities display-name
)
1373 (if user-slug
(pretty-number (or (cdr (assoc :karma user-info
)) 0)) "##"))
1374 (sublevel-nav-to-html out-stream
1375 `(:all
:posts
:comments
1377 '(:drafts
:conversations
:inbox
)))
1380 (when (member show
'(:all
:posts
:comments
))
1381 (sublevel-nav-to-html out-stream
1386 :extra-class
"sort"))))))))
1388 (defparameter *conversation-template
* (compile-template* "conversation.html"))
1390 (define-page view-conversation
"/conversation" (id)
1393 (let ((to (post-or-get-parameter "to")))
1395 ((and id to
) (error "This is an invalid URL."))
1397 (multiple-value-bind (conversation messages
)
1398 (get-conversation-messages id
(hunchentoot:cookie-in
"lw2-auth-token"))
1399 (view-items-index (nreverse messages
) :content-class
"conversation-page" :need-auth t
:title
(encode-entities (postprocess-conversation-title (cdr (assoc :title conversation
))))
1400 :top-nav
(lambda (out-stream) (render-template* *conversation-template
* out-stream
1401 :conversation conversation
:csrf-token
(make-csrf-token))))))
1403 (emit-page (out-stream :title
"New conversation" :content-class
"conversation-page")
1404 (render-template* *conversation-template
* out-stream
1406 :csrf-token
(make-csrf-token)))))))
1407 (:post
((text :required t
))
1408 (let* ((subject (post-or-get-parameter "subject"))
1409 (to (post-or-get-parameter "to"))
1411 (let ((participant-ids (list (logged-in-userid) (cdar (lw2-graphql-query (lw2-query-string :user
:single
(alist :slug to
) '(:--id
)))))))
1412 (do-create-conversation (hunchentoot:cookie-in
"lw2-auth-token") (alist :participant-ids participant-ids
:title subject
))))))
1413 (do-create-message (hunchentoot:cookie-in
"lw2-auth-token") id text
)
1414 (redirect (format nil
"/conversation?id=~A" id
))))))
1416 (defun search-result-markdown-to-html (item)
1417 (cons (cons :html-body
1418 (handler-case (markdown:parse
(cdr (assoc :body item
)))
1419 (serious-condition () "[Error while processing search result]")))
1422 (define-page view-search
"/search" ((q :required t
))
1423 (let ((*current-search-query
* q
)
1424 (link (convert-any-link* q
)))
1425 (declare (special *current-search-query
*))
1428 (multiple-value-bind (posts comments
) (lw2-search-query q
)
1429 (view-items-index (nconc (map 'list
(lambda (p) (if (cdr (assoc :comment-count p
)) p
(cons (cons :comment-count
0) p
))) posts
)
1430 (map 'list
#'search-result-markdown-to-html comments
))
1431 :content-class
"search-results-page" :current-uri
"/search"
1432 :title
(format nil
"~@[~A - ~]Search" q
))))))
1434 (define-page view-login
"/login" (return cookie-check
1435 (csrf-token :request-type
:post
) (login-username :request-type
:post
) (login-password :request-type
:post
)
1436 (signup-username :request-type
:post
) (signup-email :request-type
:post
) (signup-password :request-type
:post
) (signup-password2 :request-type
:post
))
1438 ((emit-login-page (&key error-message
)
1439 (let ((csrf-token (make-csrf-token)))
1440 (emit-page (out-stream :title
"Log in" :current-uri
"/login" :content-class
"login-page" :robots
"noindex, nofollow")
1442 (format out-stream
"<div class=\"error-box\">~A</div>" error-message
))
1443 (with-outputs (out-stream) "<div class=\"login-container\">")
1444 (output-form out-stream
"post" (format nil
"/login~@[?return=~A~]" (if return
(url-rewrite:url-encode return
))) "login-form" "Log in" csrf-token
1445 '(("login-username" "Username" "text" "username")
1446 ("login-password" "Password" "password" "current-password"))
1448 :end-html
"<a href=\"/reset-password\">Forgot password</a>")
1449 (output-form out-stream
"post" (format nil
"/login~@[?return=~A~]" (if return
(url-rewrite:url-encode return
))) "signup-form" "Create account" csrf-token
1450 '(("signup-username" "Username" "text" "username")
1451 ("signup-email" "Email" "text" "email")
1452 ("signup-password" "Password" "password" "new-password")
1453 ("signup-password2" "Confirm password" "password" "new-password"))
1455 (alexandria:if-let
(main-site-title (main-site-title *current-site
*))
1456 (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>"
1458 (format out-stream
"</div>"))))
1459 (finish-login (username user-id auth-token error-message
&optional expires
)
1462 (set-cookie "lw2-auth-token" auth-token
:max-age
(and expires
(+ (- expires
(get-unix-time)) (* 24 60 60))))
1463 (if expires
(set-cookie "lw2-status" (json:encode-json-to-string
(alist :expires expires
))))
1464 (cache-put "auth-token-to-userid" auth-token user-id
)
1465 (cache-put "auth-token-to-username" auth-token username
)
1466 (redirect (if (and return
(ppcre:scan
"^/[^/]" return
)) return
"/")))
1468 (emit-login-page :error-message error-message
)))))
1470 ((not (or cookie-check
(hunchentoot:cookie-in
"session-token")))
1471 (set-cookie "session-token" (base64:usb8-array-to-base64-string
(ironclad:make-random-salt
)))
1472 (redirect (format nil
"/login?~@[return=~A&~]cookie-check=y" (if return
(url-rewrite:url-encode return
)))))
1474 (if (hunchentoot:cookie-in
"session-token")
1475 (redirect (format nil
"/login~@[?return=~A~]" (if return
(url-rewrite:url-encode return
))))
1476 (emit-page (out-stream :title
"Log in" :current-uri
"/login")
1477 (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
))))))
1479 (check-csrf-token csrf-token
)
1481 ((or (string= login-username
"") (string= login-password
"")) (emit-login-page :error-message
"Please enter a username and password"))
1482 (t (multiple-value-call #'finish-login login-username
(do-login "username" login-username login-password
)))))
1484 (check-csrf-token csrf-token
)
1486 ((not (every (lambda (x) (not (string= x
""))) (list signup-username signup-email signup-password signup-password2
)))
1487 (emit-login-page :error-message
"Please fill in all fields"))
1488 ((not (string= signup-password signup-password2
))
1489 (emit-login-page :error-message
"Passwords do not match"))
1490 (t (multiple-value-call #'finish-login signup-username
(do-lw2-create-user signup-username signup-email signup-password
)))))
1492 (emit-login-page)))))
1494 (define-page view-logout
"/logout" ((logout :request-type
:post
))
1495 (check-csrf-token logout
)
1496 (set-cookie "lw2-auth-token" "" :max-age
0)
1499 (defparameter *reset-password-template
* (compile-template* "reset-password.html"))
1501 (define-page view-reset-password
"/reset-password" ((csrf-token :request-type
:post
) (email :request-type
:post
) (reset-link :request-type
:post
) (password :request-type
:post
) (password2 :request-type
:post
))
1502 (labels ((emit-rpw-page (&key message message-type step
)
1503 (let ((csrf-token (make-csrf-token)))
1504 (emit-page (out-stream :title
"Reset password" :content-class
"reset-password" :robots
"noindex, nofollow")
1505 (render-template* *reset-password-template
* out-stream
1506 :csrf-token csrf-token
1507 :reset-link reset-link
1509 :message-type message-type
1513 (check-csrf-token csrf-token
)
1514 (multiple-value-bind (ret error
)
1515 (do-lw2-forgot-password email
)
1516 (declare (ignore ret
))
1518 (emit-rpw-page :step
1 :message error
:message-type
"error")
1519 (emit-rpw-page :step
1 :message
"Password reset email sent." :message-type
"success"))))
1521 (ppcre:register-groups-bind
(reset-token) ("(?:reset-password/|^)([^/#]+)$" reset-link
)
1524 (emit-rpw-page :step
2 :message
"Invalid password reset link." :message-type
"error"))
1525 ((not (string= password password2
))
1526 (emit-rpw-page :step
2 :message
"Passwords do not match." :message-type
"error"))
1528 (check-csrf-token csrf-token
)
1529 (multiple-value-bind (user-id auth-token error-message
) (do-lw2-reset-password reset-token password
)
1530 (declare (ignore user-id auth-token
))
1532 (error-message (emit-rpw-page :step
2 :message error-message
:message-type
"error"))
1534 (with-error-page (emit-page (out-stream :title
"Reset password" :content-class
"reset-password")
1535 (format out-stream
"<h1>Password reset complete</h1><p>You can now <a href=\"/login\">log in</a> with your new password.</p>"))))))))))
1539 (defun firstn (list n
)
1544 (defparameter *earliest-post
* (local-time:parse-timestring
"2005-01-01"))
1546 (define-page view-archive
(:regex
"^/archive(?:/(\\d{4})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))(?:/(\\d{1,2})|/?(?:$|\\?.*$))"
1547 (year :type
(mod 10000))
1548 (month :type
(integer 1 12))
1549 (day :type
(integer 1 31)))
1550 ((offset :type fixnum
:default
0))
1551 (local-time:with-decoded-timestamp
(:day current-day
:month current-month
:year current-year
) (local-time:now
)
1552 (local-time:with-decoded-timestamp
(:day earliest-day
:month earliest-month
:year earliest-year
) *earliest-post
*
1553 (labels ((url-elements (&rest url-elements
)
1554 (declare (dynamic-extent url-elements
))
1555 (format nil
"/~{~A~^/~}" url-elements
))
1556 (archive-nav (out-stream)
1557 (with-outputs (out-stream) "<div class=\"archive-nav\"><div class=\"archive-nav-years\">")
1558 (link-if-not out-stream
(not (or year month day
)) (url-elements "archive") "archive-nav-item-year" "All")
1559 (loop for y from earliest-year to current-year
1560 do
(link-if-not out-stream
(eq y year
) (url-elements "archive" y
) "archive-nav-item-year" y
))
1561 (format out-stream
"</div>")
1563 (format out-stream
"<div class=\"archive-nav-months\">")
1564 (link-if-not out-stream
(not month
) (url-elements "archive" year
) "archive-nav-item-month" "All")
1565 (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)
1566 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
)))
1567 (format out-stream
"</div>"))
1569 (format out-stream
"<div class=\"archive-nav-days\">")
1570 (link-if-not out-stream
(not day
) (url-elements "archive" year month
) "archive-nav-item-day" "All")
1571 (loop for d from
(if (and (= (or year current-year
) earliest-year
) (= (or month current-month
) earliest-month
)) earliest-day
1)
1572 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
)))
1573 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
))
1574 (format out-stream
"</div>"))
1575 (format out-stream
"</div>")))
1576 (multiple-value-bind (posts total
)
1577 (lw2-graphql-query (lw2-query-string :post
:list
1578 (alist :view
(if day
"new" "top") :limit
51 :offset offset
1579 :after
(if (and year
(not day
)) (format nil
"~A-~A-~A" (or year earliest-year
) (or month
1) (or day
1)))
1580 :before
(if year
(format nil
"~A-~A-~A" (or year current-year
) (or month
12)
1581 (or day
(local-time:days-in-month
(or month
12) (or year current-year
))))))
1582 (posts-index-fields)))
1583 (emit-page (out-stream :title
"Archive" :current-uri
"/archive" :content-class
"archive-page"
1584 :top-nav
#'archive-nav
1585 :pagination
(pagination-nav-bars :items-per-page
50 :offset offset
:total total
:with-next
(if total nil
(> (length posts
) 50))))
1586 (write-index-items-to-html out-stream
(firstn posts
50) :empty-message
"No posts for the selected period.")))))))
1588 (define-page view-about
"/about" ()
1589 (emit-page (out-stream :title
"About" :current-uri
"/about" :content-class
"about-page")
1590 (alexandria:with-input-from-file
(in-stream "www/about.html" :element-type
'(unsigned-byte 8))
1591 (alexandria:copy-stream in-stream out-stream
))))
1593 (hunchentoot:define-easy-handler
(view-versioned-resource :uri
(lambda (r)
1594 (multiple-value-bind (file content-type
)
1595 #.
(labels ((defres (uri content-type
)
1596 `(,uri
(values (concatenate 'string
"www" ,uri
) ,content-type
))))
1598 '(alexandria:switch
((hunchentoot:script-name r
) :test
#'string
=))
1599 (loop for system in
'("mac" "windows" "linux") nconc
1600 (loop for theme in
'(nil "dark" "grey" "ultramodern" "zero" "brutalist" "rts")
1601 collect
(defres (format nil
"/css/style~@[-~A~].~A.css" theme system
) "text/css")))
1602 (loop for
(uri content-type
) in
1603 '(("/script.js" "text/javascript")
1604 ("/assets/favicon.ico" "image/x-icon"))
1605 collect
(defres uri content-type
))))
1607 (when (assoc "v" (hunchentoot:get-parameters r
) :test
#'string
=)
1608 (setf (hunchentoot:header-out
"Cache-Control") (format nil
"public, max-age=~A, immutable" (- (expt 2 31) 1))))
1609 (hunchentoot:handle-static-file file content-type
)