~A~A "
29 | js-time
30 | pretty-time
31 | (pretty-time-js))))
32 |
33 | (defun pretty-number (number &optional object (output-format :html))
34 | (with-output-to-string (*standard-output*)
35 | (when (minusp number)
36 | (write-char #\MINUS_SIGN))
37 | (format t "~:D" (abs number))
38 | (when object
39 | (flet ((write-object () (format t " ~A~P" object number)))
40 | (cond ((eq output-format :html)
41 | (write-string "")
42 | (write-object)
43 | (write-string " "))
44 | (t (write-object)))))))
45 |
46 | (defun maybe-need-auth (link need-auth)
47 | (if need-auth
48 | (concatenate 'string link "?need-auth=y")
49 | link))
50 |
51 | (define-compiler-macro generate-post-auth-link (post &rest args &key need-auth &allow-other-keys)
52 | `(maybe-need-auth (generate-item-link :post ,post ,@(alexandria:remove-from-plist args :need-auth)) ,need-auth))
53 |
54 | (defun generate-post-auth-link (post &rest args &key need-auth &allow-other-keys)
55 | (maybe-need-auth (apply #'generate-item-link :post post :allow-other-keys t args) need-auth))
56 |
57 | (defun clean-lw-link (url)
58 | (when url
59 | (let* ((url (ppcre:regex-replace "([^/]*//[^/]*)lesserwrong\.com" url "\\1lesswrong.com"))
60 | (url (ppcre:regex-replace "([^/:]*://[^/]*)forum-bots\.effectivealtruism.org" url "\\1forum.effectivealtruism.org")))
61 | url)))
62 |
63 | (defun votes-to-tooltip (votes)
64 | (if votes
65 | (format nil "~A vote~:*~P"
66 | (typecase votes (integer votes) (list (length votes))))
67 | ""))
68 |
69 | (defun vote-buttons (base-score &key (with-buttons t) vote-count post-id af-score as-text extended-score extended-vote-style)
70 | (labels ((button (vote-type)
71 | (when with-buttons
72 |
103 | (button "upvote")
104 | (safe text)
105 | (button "downvote")
106 |
107 |
))
108 | (if as-text
109 | (hash-cond (make-hash-table)
110 | (base-score :karma (list (text) (votes-to-tooltip vote-count)))
111 | (extended-score :agreement (list (extended-text)
112 | (extended-tooltip))))
113 | (progn
114 | (when base-score
115 | (voting "karma" (votes-to-tooltip vote-count) (text)))
116 | (when extended-vote-style
117 | (voting "agreement"
118 | (extended-tooltip)
119 | (extended-text)))))))
120 |
--------------------------------------------------------------------------------
/src/legacy-archive.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.legacy-archive
2 | (:use #:cl #:lw2.utils #:lw2.backend)
3 | (:import-from #:cl-ppcre #:regex-replace-all)
4 | (:export #:lw-legacy-url #:check-wayback-availability #:wayback-unmodified-url))
5 |
6 | (in-package #:lw2.legacy-archive)
7 |
8 | ;; Should match the behavior of https://github.com/tricycle/lesswrong/blob/925eb95151c6aaf1e97efe630a25516af493f9e4/r2/r2/lib/utils/utils.py#L1011
9 | (defun lw-legacy-slug (title)
10 | (let* ((max-length 50)
11 | (title (regex-replace-all "\\s+" title "_"))
12 | (title (regex-replace-all "\\W+" title ""))
13 | (title (regex-replace-all "_+" title "_"))
14 | (title (string-trim "_" title))
15 | (title (string-downcase title)))
16 | (if (> (length title) max-length)
17 | (substring title 0 (or (position #\_ title :end max-length :from-end t)
18 | max-length))
19 | title)))
20 |
21 | (defun lw-legacy-id-string (legacy-id)
22 | (format nil "~(~36R~)"
23 | (etypecase legacy-id
24 | (string (parse-integer legacy-id))
25 | (integer legacy-id))))
26 |
27 | (defun lw-legacy-url (legacy-id title &key (section :main))
28 | (format nil "~Alw/~A/~A"
29 | (case section
30 | (:main "http://lesswrong.com/")
31 | (:discussion "http://lesswrong.com/r/discussion/")
32 | (t ""))
33 | (lw-legacy-id-string legacy-id)
34 | (lw-legacy-slug title)))
35 |
36 | (defun check-wayback-availability (url)
37 | (let* ((wayback-api-url
38 | (quri:make-uri :defaults "https://archive.org/wayback/available"
39 | :query (alist "url" url
40 | "timestamp" "2009")))
41 | (timestamp
42 | (trivia:match
43 | (call-with-http-response #'json:decode-json wayback-api-url :want-stream t :force-string t)
44 | ((assoc :archived--snapshots
45 | (assoc :closest
46 | (assoc :timestamp timestamp)))
47 | timestamp))))
48 | (and timestamp
49 | (values (parse-integer timestamp)))))
50 |
51 | (defun wayback-unmodified-url (url)
52 | (let ((timestamp (check-wayback-availability url)))
53 | (when timestamp
54 | (format nil "https://web.archive.org/web/~Aid_/~A" timestamp url))))
55 |
--------------------------------------------------------------------------------
/src/links.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.links
2 | (:use #:cl #:alexandria #:lw2.utils #:lw2.lmdb #:lw2.backend #:lw2.sites #:lw2.context #:lw2-viewer.config)
3 | (:export #:sanitize-link
4 | #:match-lw1-link #:convert-lw1-link
5 | #:match-ea1-link #:convert-ea1-link
6 | #:match-overcomingbias-link #:convert-overcomingbias-link
7 | #:direct-link #:with-direct-link
8 | #:match-lw2-link #:match-lw2-slug-link #:match-lw2-sequence-link #:convert-lw2-link #:convert-lw2-slug-link #:convert-lw2-sequence-link #:convert-lw2-misc-link
9 | #:generate-item-link
10 | #:convert-any-link* #:convert-any-link #:presentable-link)
11 | (:unintern #:generate-post-link #:convert-lw2-user-link))
12 |
13 | (in-package #:lw2.links)
14 |
15 | (defun sanitize-link (link)
16 | (substitute #\+ #\Space (string-trim " " link)))
17 |
18 | (defun get-redirect (uri)
19 | (multiple-value-bind (body status headers uri)
20 | (dex:request uri :method :head :max-redirects 0 :keep-alive nil)
21 | (declare (ignore body uri))
22 | (let ((location (gethash "location" headers)))
23 | (if (and (typep status 'integer) (< 300 status 400) location)
24 | location
25 | nil))))
26 |
27 | (defmacro match-values (regex input registers)
28 | (with-gensyms (match? strings)
29 | (labels ((register-body (x)
30 | (typecase x
31 | (integer `(elt ,strings ,x))
32 | (atom x)
33 | (t (cons (register-body (car x)) (register-body (cdr x)))))))
34 | `(multiple-value-bind (,match? ,strings) (ppcre:scan-to-strings ,regex ,input)
35 | (when ,match?
36 | (values ,.(register-body registers)))))))
37 |
38 | (defmethod link-for-site-p ((s site) link) nil)
39 |
40 | (defmethod link-for-site-p ((s lesswrong-viewer-site) link)
41 | (ppcre:scan "^https?://(?:www\\.)?(?:less(?:er|est)?wrong\\.com|alignmentforum\\.org)" link))
42 |
43 | (defmethod link-for-site-p ((s ea-forum-viewer-site) link)
44 | (ppcre:scan "^https?://(?:www\\.)?(?:effective-altruism\\.com|forum\\.effectivealtruism\\.org)" link))
45 |
46 | (defmethod link-for-site-p ((s progress-forum-viewer-site) link)
47 | (ppcre:scan "^https?://(?:www\\.)?progressforum\\.org" link))
48 |
49 | (defmethod link-for-site-p ((s arbital-site) link)
50 | (ppcre:scan "^https?://(?:www\\.)?(?:arbital\\.com)" link))
51 |
52 | (defun find-link-site (link)
53 | (if (ppcre:scan "^/(?!/)" link)
54 | *current-site*
55 | (loop for s in *sites*
56 | when (link-for-site-p s link) return s)))
57 |
58 | (defun site-link-prefix (site)
59 | (if (eq site *current-site*)
60 | "/"
61 | (site-uri site)))
62 |
63 | (defun match-lw1-link (link) (match-values "(?:^https?://(?:www.)?less(?:er|est)?wrong.com|^)(?:/r/discussion|/r/lesswrong|/r/all)?(/lw/.*)" link (0)))
64 |
65 | (defun match-ea1-link (link) (match-values "^(?:https?://(?:www\\.)?(?:effective-altruism\\.com|forum\\.effectivealtruism\\.org))?(/ea/.*)" link (0)))
66 |
67 | (defun match-agentfoundations-link (link) (match-values "^(?:https?://(?:www\\.)?agentfoundations\\.org)?(/item\\?id=.*)" link (0)))
68 |
69 | (defun match-lw2-link (link) (match-values "^(?:https?://[^/]+)?/(post|event)s/([^/]+)(?:/([^/#?]*)(?:/(comment|answer)/([^/#?]+)|/?(?:#(?:comment-)?|\\?commentId=)([^/#]+))?)?" link (1 (or 4 5) 2 3 0)))
70 |
71 | (defun match-lw2-slug-link (link) (match-values "^(?:https?://(?:www.)?less(?:er|est)?wrong.com)?/(?:codex|hpmor)/([^/#]+)(?:/?#?([^/#]+)?)?" link (0 1)))
72 |
73 | (defun match-lw2-sequence-link (link) (match-values "^(?:https?://[^/]+)?/s/([^/#]+)(?:/p/([^/#]+))?(?:#([^/#]+)?)?" link (0 1 2)))
74 |
75 | (defun convert-lw2-misc-link (link)
76 | (when-let* ((site (find-link-site link))
77 | (matched-link (and (typep site '(or lesswrong-viewer-site ea-forum-viewer-site)) (match-values "^(?:https?://[^/]+)?/((?:users/|tags|tag/|w/|topics/|s/|sequences/|library).*)" link (0)))))
78 | (concatenate 'string (site-link-prefix site) matched-link)))
79 |
80 | (defun convert-arbital-link (link)
81 | (when-let* ((site (find-link-site link))
82 | (matched-link (and (typep site 'arbital-site) (match-values "^(?:https?://[^/]+)?/(.*)" link (0)))))
83 | (concatenate 'string (site-link-prefix site) matched-link)))
84 |
85 | (defmacro with-direct-link-restart ((direct-link) &body body)
86 | (once-only (direct-link)
87 | `(restart-case (progn ,@body)
88 | (direct-link () :report "Use direct link." ,direct-link))))
89 |
90 | (defun direct-link (&optional c)
91 | (declare (ignore c))
92 | (if-let (restart (find-restart 'direct-link))
93 | (invoke-restart restart)))
94 |
95 | (defmacro with-direct-link (&body body)
96 | `(handler-bind
97 | ((serious-condition #'direct-link))
98 | (progn ,@body)))
99 |
100 | (defun process-redirect-link (link base-uri site-name)
101 | (if-let ((location (get-redirect (concatenate 'string base-uri link))))
102 | (let ((loc-uri (quri:uri location)))
103 | (format nil "~A~@[#comment-~A~]"
104 | (quri:uri-path loc-uri)
105 | (or (quri:uri-fragment loc-uri)
106 | (cdr (assoc "commentId" (quri:uri-query-params loc-uri)
107 | :test #'string-equal)))))
108 | (error "Could not retrieve ~A link.
You may wish to try ~:*~A " site-name (concatenate 'string base-uri link))))
109 |
110 | (defun convert-redirect-link (link match-fn get-fn base-uri)
111 | (if-let (matched-link (funcall match-fn link))
112 | (with-direct-link-restart ((concatenate 'string base-uri matched-link))
113 | (merge-uris (funcall get-fn matched-link)
114 | (site-uri (find-link-site base-uri))))))
115 |
116 | (simple-cacheable ("lw1-link" 'backend-lmdb-cache "lw1-link" link :catch-errors nil)
117 | (process-redirect-link link "https://www.lesswrong.com" "LessWrong 1.0"))
118 |
119 | (defun convert-lw1-link (link)
120 | (convert-redirect-link link #'match-lw1-link #'get-lw1-link "https://www.lesswrong.com"))
121 |
122 | (simple-cacheable ("ea1-link" 'backend-lmdb-cache "ea1-link" link :catch-errors nil)
123 | (process-redirect-link link "https://forum.effectivealtruism.org" "EA Forum 1.0"))
124 |
125 | (defun convert-ea1-link (link)
126 | (convert-redirect-link link #'match-ea1-link #'get-ea1-link "https://forum.effectivealtruism.org"))
127 |
128 | (defun match-overcomingbias-link (link)
129 | (if (ppcre:scan "^https?://(?:www\\.)?overcomingbias\\.com/" link)
130 | link
131 | nil))
132 |
133 | (simple-cacheable ("overcomingbias-link" 'backend-lmdb-cache "overcomingbias-link" link :catch-errors nil)
134 | (if-let ((location (get-redirect link)))
135 | (match-lw1-link location)
136 | ""))
137 |
138 | (defun convert-overcomingbias-link (link)
139 | (when (match-overcomingbias-link link)
140 | (with-direct-link-restart (link)
141 | (let ((lw1-link (get-overcomingbias-link link)))
142 | (if (string= lw1-link "")
143 | nil
144 | (convert-lw1-link lw1-link))))))
145 |
146 | (simple-cacheable ("agentfoundations-link" 'backend-lmdb-cache "agentfoundations-link" link :catch-errors nil)
147 | (process-redirect-link link "https://www.lesswrong.com" "Agent Foundations"))
148 |
149 | (defun convert-agentfoundations-link (link)
150 | (convert-redirect-link link #'match-agentfoundations-link #'get-agentfoundations-link "https://www.lesswrong.com"))
151 |
152 | (defun gen-internal (post-id slug comment-id &optional absolute-uri stream item-subtype)
153 | (format stream "~A~As/~A/~A~:[~@[#~A~]~;~@[#comment-~A~]~]" (or absolute-uri "/") (or item-subtype "post") post-id (or slug (get-post-slug post-id) "-") (and comment-id (= (length comment-id) 17)) comment-id))
154 |
155 | (defun convert-lw2-slug-link (link)
156 | (multiple-value-bind (slug comment-id) (match-lw2-slug-link link)
157 | (when slug
158 | (gen-internal (get-slug-postid slug) slug comment-id))))
159 |
160 | (defun convert-lw2-sequence-link (link)
161 | (if-let (site (find-link-site link))
162 | (multiple-value-bind (sequence-id post-id comment-id) (match-lw2-sequence-link link)
163 | (cond
164 | (post-id (gen-internal post-id (get-post-slug post-id) comment-id (site-link-prefix site)))
165 | (sequence-id (format nil "~As/~A" (site-link-prefix site) sequence-id))))))
166 |
167 | (defun convert-lw2-link (link)
168 | (multiple-value-bind (post-id comment-id slug) (match-lw2-link link)
169 | (when post-id
170 | (if-let (site (find-link-site link))
171 | (gen-internal post-id slug comment-id (site-link-prefix site))))))
172 |
173 | (defun generate-item-link (item-type item-designator &key comment-id absolute stream item-subtype)
174 | (let ((absolute (if (eq absolute t) (site-uri *current-site*) absolute)))
175 | (ecase item-type
176 | (:post
177 | (typecase item-designator
178 | (string
179 | (gen-internal item-designator (get-post-slug item-designator) comment-id absolute stream (or item-subtype "post")))
180 | (cons
181 | (let ((post-id (cdr (assoc :--id item-designator))))
182 | (gen-internal post-id (or (cdr (assoc :slug item-designator)) (get-post-slug post-id)) comment-id absolute stream (or item-subtype "post"))))))
183 | (:tag
184 | (with-output-to-designator (out stream)
185 | (format out "~Atag/~A~@[#comment-~A~]" (or absolute "/") item-designator comment-id))))))
186 |
187 | (defun convert-any-link* (url)
188 | (let ((url (sanitize-link url)))
189 | (or (convert-lw2-link url)
190 | (convert-lw2-slug-link url)
191 | (convert-lw2-sequence-link url)
192 | (convert-lw1-link url)
193 | (convert-ea1-link url)
194 | (convert-agentfoundations-link url)
195 | (convert-overcomingbias-link url)
196 | (convert-lw2-misc-link url)
197 | (convert-arbital-link url))))
198 |
199 | (defun convert-any-link (url)
200 | (or (convert-any-link* url) url))
201 |
202 | (defun presentable-link (link &optional context)
203 | (or (and (ppcre:scan "^#" link) link)
204 | (and (not (eq context :image)) (convert-any-link* link))
205 | (and (not (eq context :search))
206 | (let ((sanitized-link (sanitize-link link)))
207 | (handler-case
208 | (merge-uris
209 | sanitized-link
210 | (site-link-base *current-site*))
211 | (error () sanitized-link))))))
212 |
--------------------------------------------------------------------------------
/src/macro-utils.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.macro-utils
2 | (:documentation "Facilities for working with macros.")
3 | (:use #:cl #:iterate #:trivial-cltl2)
4 | (:import-from #:introspect-environment #:compiler-macroexpand #:compiler-macroexpand-1)
5 | (:export #:compiler-constantp #:macroexpand-both-1 #:macroexpand-both
6 | #:eval-in-environment
7 | #:augment-macros #:macro-as-lambda #:macro-list-as-lambdas))
8 |
9 | (in-package #:lw2.macro-utils)
10 |
11 | (defun compiler-constantp (form &optional environment)
12 | "Like CONSTANTP, but also try expanding compiler macros."
13 | (or (constantp form environment)
14 | (constantp (compiler-macroexpand form environment) environment)))
15 |
16 | (defun macroexpand-both-1 (form &optional environment)
17 | (multiple-value-bind (result expandedp) (macroexpand-1 form environment)
18 | (multiple-value-bind (result c-expandedp) (compiler-macroexpand-1 result environment)
19 | (values result (or expandedp c-expandedp)))))
20 |
21 | (defun macroexpand-both (form &optional environment)
22 | (let (result expandedp any-expandedp)
23 | (iter
24 | (multiple-value-setq (result expandedp) (macroexpand-both-1 form environment))
25 | (while expandedp)
26 | (setf any-expandedp t))
27 | (values result any-expandedp)))
28 |
29 | (defun eval-in-environment (form &optional environment)
30 | (funcall (enclose `(lambda () ,form) environment)))
31 |
32 | (defun augment-macros (environment macro-bindings)
33 | "Add a set of MACROLET-style macro bindings to an environment."
34 | (let ((macro-list (iter (for (name args . body) in macro-bindings)
35 | (for macro-lambda = (parse-macro name args body))
36 | (for macro-fn = (enclose macro-lambda environment))
37 | (collect (list name macro-fn)))))
38 | (augment-environment environment :macro macro-list)))
39 |
40 | (defmacro macro-as-lambda (name args &body body)
41 | "Create a macro expander function as a lambda form."
42 | (parse-macro name args body))
43 |
44 | (defmacro macro-list-as-lambdas (&rest clauses)
45 | "Create a list of macro expander functions as lambda forms. This is
46 | suitable for passing to AUGMENT-ENVIRONMENT."
47 | `(list
48 | ,@(iter (for (name args . body) in clauses)
49 | (collect `(list ',name ,(parse-macro name args body))))))
50 |
--------------------------------------------------------------------------------
/src/push-notifications.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:lw2.backend)
2 |
3 | (define-cache-database 'backend-push-notifications "push-subscriptions")
4 |
5 | (export 'make-subscription)
6 | (defun make-subscription (auth-token endpoint expires)
7 | (cache-put "push-subscriptions"
8 | auth-token
9 | (alist :endpoint endpoint
10 | :expires expires)
11 | :value-type :json))
12 |
13 | (export 'find-subscription)
14 | (defun find-subscription (auth-token)
15 | (cache-get "push-subscriptions" auth-token :value-type :json))
16 |
17 | (export 'delete-subscription)
18 | (defun delete-subscription (auth-token)
19 | (cache-del "push-subscriptions" auth-token))
20 |
21 | (export 'send-all-notifications)
22 | (define-backend-function send-all-notifications ()
23 | (backend-push-notifications
24 | (let* ((all-subscriptions
25 | (with-collector (col)
26 | (call-with-cursor "push-subscriptions"
27 | (lambda (db cursor)
28 | (declare (ignore db))
29 | (multiple-value-bind (value key) (cursor-get cursor :first)
30 | (loop while key do
31 | (col (cons key value))
32 | (multiple-value-setq (value key) (cursor-get cursor :next)))))
33 | :read-only t)
34 | (col)))
35 | (current-time (local-time:now))
36 | (current-time-unix (local-time:timestamp-to-unix current-time)))
37 | (loop for (auth-token . subscription-json) in all-subscriptions
38 | do (log-and-ignore-errors
39 | (let* ((subscription (json:decode-json-from-string subscription-json))
40 | (last-check-cons (or (assoc :last-check subscription) (cons :last-check nil)))
41 | (since (if-let (unix (cdr last-check-cons)) (local-time:unix-to-timestamp unix))))
42 | (cond
43 | ((let ((expires (cdr (assoc :expires subscription)))) (and expires (> current-time-unix expires)))
44 | (delete-subscription auth-token))
45 | ((sb-sys:with-deadline (:seconds 30)
46 | (check-notifications (cache-get "auth-token-to-userid" auth-token) auth-token :since since))
47 | (handler-case
48 | (sb-sys:with-deadline (:seconds 30)
49 | (send-notification (cdr (assoc :endpoint subscription))))
50 | (dex:http-request-gone ()
51 | (delete-subscription auth-token))
52 | (:no-error (&rest args)
53 | (declare (ignore args))
54 | (setf (cdr last-check-cons) (local-time:timestamp-to-unix current-time))
55 | (cache-put "push-subscriptions" auth-token (adjoin last-check-cons subscription) :value-type :json))))))))))
56 | (backend-base nil))
57 |
--------------------------------------------------------------------------------
/src/raw-memory-streams.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.raw-memory-streams
2 | (:use #:cl #:trivial-gray-streams)
3 | (:export #:raw-memory-stream))
4 |
5 | (in-package #:lw2.raw-memory-streams)
6 |
7 | (defclass raw-memory-stream (fundamental-binary-input-stream)
8 | ((pointer :initarg :pointer)
9 | (length :initarg :length :initform (error "No length parameter supplied when creating raw-memory-stream") :type (and fixnum (integer 0)))
10 | (position :initform 0 :type fixnum :accessor stream-file-position)))
11 |
12 | (defmethod stream-element-type ((self raw-memory-stream))
13 | '(unsigned-byte 8))
14 |
15 | (defmethod stream-read-byte ((self raw-memory-stream))
16 | (declare (optimize (safety 0) (debug 0)))
17 | (with-slots (pointer length position) self
18 | (declare (type (and fixnum (integer 0)) length position)
19 | (type cffi:foreign-pointer pointer))
20 | (if (>= position length)
21 | :eof
22 | (prog1
23 | (cffi:mem-aref pointer :unsigned-char position)
24 | (setf position (the fixnum (+ 1 position)))))))
25 |
26 | (defmethod stream-read-sequence ((self raw-memory-stream) sequence start end &key)
27 | (declare (optimize (safety 0) (debug 0))
28 | (type (and fixnum (integer 0)) start end))
29 | (with-slots (pointer length position) self
30 | (declare (type (and fixnum (integer 0)) length position)
31 | (type cffi:foreign-pointer pointer))
32 | (let* ((remaining-length (- length position))
33 | (requested-length (- end start))
34 | (actual-length (min remaining-length requested-length)))
35 | (declare (type (and fixnum (integer 0)) remaining-length requested-length actual-length))
36 | (macrolet ((inner ()
37 | `(loop for mem-index from position to (+ position actual-length)
38 | for sequence-index from start
39 | do (setf (elt sequence sequence-index)
40 | (cffi:mem-aref pointer :unsigned-char mem-index)))))
41 | (etypecase sequence
42 | ((simple-array (unsigned-byte 8) (*)) (inner))
43 | ((array (unsigned-byte 8) (*)) (inner))
44 | (sequence (inner))))
45 | (setf position (the fixnum (+ position actual-length)))
46 | (the fixnum (+ start actual-length)))))
47 |
--------------------------------------------------------------------------------
/src/response.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.response
2 | (:use #:cl #:lw2.utils #:lw2.conditions #:lw2.sites #:lw2.routes)
3 | (:import-from #:lw2.html-reader #:*html-output*)
4 | (:export #:with-response-context #:with-response-stream #:define-json-endpoint)
5 | (:recycle #:lw2-viewer))
6 |
7 | (in-package #:lw2.response)
8 |
9 | (defun call-with-response-context (fn)
10 | (with-site-context ((let ((host (or (hunchentoot:header-in* :x-forwarded-host) (hunchentoot:header-in* :host))))
11 | (or (find-site host)
12 | (error "Unknown site: ~A" host))))
13 | (funcall fn)))
14 |
15 | (defmacro with-response-context (() &body body)
16 | `(dynamic-flet ((fn () ,@body)) (call-with-response-context #'fn)))
17 |
18 | (defun call-with-response-stream (fn)
19 | (unless (eq (hunchentoot:request-method*) :head)
20 | (let ((*html-output* (flex:make-flexi-stream (hunchentoot:send-headers) :external-format :utf-8)))
21 | (handler-case
22 | (funcall fn *html-output*)
23 | (serious-condition () (close *html-output*))
24 | (:no-error (&rest x) (declare (ignore x)) (finish-output *html-output*))))))
25 |
26 | (defmacro with-response-stream ((out-stream) &body body) `(dynamic-flet ((fn (,out-stream) ,@body)) (call-with-response-stream #'fn)))
27 |
28 | (defun serve-json-request (fn)
29 | (with-response-context ()
30 | (let ((result
31 | (handler-case (funcall fn)
32 | (fatal-error (condition)
33 | (setf (hunchentoot:return-code*) (condition-http-return-code condition))
34 | (list-cond (t :error (princ-to-string condition))
35 | #|todo (*debug-mode* :backtrace ...)|#)))))
36 | (setf (hunchentoot:content-type*) "application/json")
37 | (with-response-stream (out-stream)
38 | (json:encode-json result out-stream)))))
39 |
40 | (defmacro define-json-endpoint ((name site-class uri) &body body)
41 | `(define-route ',site-class 'standard-route :name ',name :uri ,uri
42 | :handler (lambda () (dynamic-flet ((fn () ,@body)) (serve-json-request #'fn)))))
43 |
--------------------------------------------------------------------------------
/src/routes.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.routes
2 | (:use #:cl #:lw2.utils)
3 | (:export #:route #:route-name #:standard-route #:execute-route
4 | #:function-route #:no-match
5 | #:regex-route))
6 |
7 | (in-package #:lw2.routes)
8 |
9 | (defclass route ()
10 | ((name :initarg :name :accessor route-name :type symbol)
11 | (handler :initarg :handler :type function)))
12 |
13 | (defclass standard-route (route)
14 | ((uri :initarg :uri :type string)))
15 |
16 | (defmethod execute-route ((r standard-route) request-uri)
17 | (with-slots (uri handler) r
18 | (if (string= uri request-uri)
19 | (progn
20 | (funcall handler)
21 | t)
22 | nil)))
23 |
24 | (defclass function-route (route)
25 | ((function :initarg :function :type function)))
26 |
27 | (define-condition no-match () ())
28 |
29 | (defmethod execute-route ((r function-route) request-uri)
30 | (with-slots (function handler) r
31 | (handler-case
32 | (progn
33 | (multiple-value-call handler (funcall function request-uri))
34 | t)
35 | (no-match () nil))))
36 |
37 | (defclass regex-route (function-route) ())
38 |
39 | (defmethod initialize-instance :around ((r regex-route) &rest args &key regex &allow-other-keys)
40 | (let* ((scanner (ppcre:create-scanner regex))
41 | (function
42 | (lambda (request-uri)
43 | (multiple-value-bind (match? strings)
44 | (ppcre:scan-to-strings scanner request-uri)
45 | (if match?
46 | (values-list (coerce strings 'list))
47 | (signal (load-time-value (make-condition 'no-match))))))))
48 | (apply #'call-next-method
49 | r
50 | :function function
51 | (map-plist
52 | (lambda (k v) (unless (eq k :regex) (list k v)))
53 | args))))
54 |
--------------------------------------------------------------------------------
/src/rwlock.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.rwlock
2 | (:use #:cl)
3 | (:import-from #:sb-thread
4 | #:make-mutex #:with-mutex #:grab-mutex #:release-mutex
5 | #:make-waitqueue #:condition-notify #:condition-broadcast #:condition-wait)
6 | (:import-from #:sb-ext
7 | #:atomic-incf #:atomic-decf)
8 | (:import-from #:sb-sys
9 | #:without-interrupts #:allow-with-interrupts #:with-interrupts)
10 | (:import-from #:alexandria
11 | #:with-gensyms
12 | #:once-only)
13 | (:export #:rwlock #:make-rwlock #:read-lock #:read-unlock #:write-lock #:write-unlock #:with-read-lock #:with-write-lock #:with-rwlock-protect))
14 |
15 | (in-package #:lw2.rwlock)
16 |
17 | (declaim (inline make-rwlock rwlock-readers rwlock-draining-readers))
18 |
19 | (defstruct rwlock
20 | (readers 0 :type sb-ext:word)
21 | (draining-readers 0 :type (signed-byte 64))
22 | (write-mutex (make-mutex))
23 | (read-waitqueue-mutex (make-mutex))
24 | (read-waitqueue (make-waitqueue))
25 | (write-waitqueue-mutex (make-mutex))
26 | (write-waitqueue (make-waitqueue)))
27 |
28 | (defmacro with-rwlock-accessors ((rwlock) &body body)
29 | `(with-accessors ,(loop for var in '(readers draining-readers write-mutex read-waitqueue-mutex read-waitqueue write-waitqueue-mutex write-waitqueue)
30 | collect `(,var ,(find-symbol (format nil "~A-~A" 'rwlock var) '#:lw2.rwlock)))
31 | ,rwlock ,@body))
32 |
33 | ;;; States:
34 | ;;; Readers running
35 | ;;; Readers draining
36 | ;;; Writer running
37 |
38 | (declaim (inline read-lock read-unlock))
39 |
40 | (defun read-lock-slowpath (rwlock)
41 | (with-rwlock-accessors (rwlock)
42 | (with-mutex (read-waitqueue-mutex)
43 | (loop until (evenp (atomic-incf readers 0))
44 | do (or (condition-wait read-waitqueue read-waitqueue-mutex) (error "Waitqueue error"))))
45 | (values nil)))
46 |
47 | (defun read-lock (rwlock)
48 | (with-rwlock-accessors (rwlock)
49 | (let ((orig-readers (atomic-incf readers 2)))
50 | (when (oddp orig-readers)
51 | (read-lock-slowpath rwlock)))
52 | (values nil)))
53 |
54 | (defun read-unlock-slowpath (rwlock)
55 | (with-rwlock-accessors (rwlock)
56 | (with-mutex (write-waitqueue-mutex)
57 | (decf (the (signed-byte 61) draining-readers))
58 | (when (= draining-readers 0)
59 | (condition-notify write-waitqueue)))
60 | (values nil)))
61 |
62 | (defun read-unlock (rwlock)
63 | (with-rwlock-accessors (rwlock)
64 | (let ((orig-readers (atomic-decf readers 2)))
65 | (when (oddp orig-readers)
66 | (read-unlock-slowpath rwlock)))
67 | (values nil)))
68 |
69 | (defun write-lock (rwlock)
70 | (with-rwlock-accessors (rwlock)
71 | (grab-mutex write-mutex)
72 | (let ((orig-readers (atomic-incf readers 1)))
73 | (unless (= orig-readers 0)
74 | (with-mutex (write-waitqueue-mutex)
75 | (incf (the (signed-byte 61) draining-readers) (the (signed-byte 61) (ash orig-readers -1)))
76 | (loop until (= draining-readers 0)
77 | do (or (condition-wait write-waitqueue write-waitqueue-mutex) (error "Waitqueue error"))))))
78 | (values nil)))
79 |
80 | (defun write-unlock (rwlock)
81 | (with-rwlock-accessors (rwlock)
82 | (with-mutex (read-waitqueue-mutex)
83 | (atomic-decf readers 1)
84 | (condition-broadcast read-waitqueue))
85 | (release-mutex write-mutex)
86 | (values nil)))
87 |
88 | (defmacro with-rwlock ((rwlock disposition) &body body)
89 | (multiple-value-bind (lock unlock) (ecase disposition
90 | (:read (values 'read-lock 'read-unlock))
91 | (:write (values 'write-lock 'write-unlock)))
92 | `(without-interrupts
93 | (allow-with-interrupts
94 | (,lock ,rwlock)
95 | (unwind-protect
96 | (with-interrupts ,@body)
97 | (,unlock ,rwlock))))))
98 |
99 | (defmacro with-read-lock ((rwlock &key upgrade-fn) &body body)
100 | (if upgrade-fn
101 | (with-gensyms (upgraded)
102 | `(let ((,upgraded nil))
103 | (flet ((,upgrade-fn ()
104 | (without-interrupts
105 | (allow-with-interrupts
106 | (read-unlock ,rwlock)
107 | (write-lock ,rwlock)
108 | (setf ,upgraded t)))))
109 | (without-interrupts
110 | (allow-with-interrupts
111 | (read-lock ,rwlock)
112 | (unwind-protect
113 | (with-interrupts ,@body)
114 | (if (not ,upgraded)
115 | (read-unlock ,rwlock)
116 | (write-unlock ,rwlock))))))))
117 | `(with-rwlock (,rwlock :read) ,@body)))
118 |
119 | (defmacro with-write-lock ((rwlock) &body body)
120 | `(with-rwlock (,rwlock :write) ,@body))
121 |
122 | (defmacro with-rwlock-protect (rwlock predicate-form write-form &body read-forms)
123 | "
124 | Protect READ-FORMS from being evaluated when PREDICATE-FORM returns false.
125 | RWLOCK will be locked in read mode. If PREDICATE-FORM returns false, RWLOCK will
126 | be upgraded to write mode and WRITE-FORM will be evaluated. WRITE-FORM should
127 | ensure that PREDICATE-FORM will return true. PREDICATE-FORM may be evaluated
128 | more than once. Returns the values returned by READ-FORMS."
129 | (once-only (rwlock)
130 | (with-gensyms (predicate-fn write-fn read-fn)
131 | `(flet ((,predicate-fn () ,predicate-form)
132 | (,write-fn () ,write-form)
133 | (,read-fn () ,@read-forms))
134 | (declare (dynamic-extent #',predicate-fn #',write-fn #',read-fn))
135 | (with-read-lock (,rwlock :upgrade-fn upgrade-lock)
136 | (unless (,predicate-fn)
137 | (upgrade-lock)
138 | (unless (,predicate-fn)
139 | (,write-fn)))
140 | (,read-fn))))))
141 |
--------------------------------------------------------------------------------
/src/schema-type.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.schema-type
2 | (:use #:cl #:lw2.utils)
3 | (:export #:define-schema-type #:undefine-schema-type #:find-schema-type #:schema-bind))
4 |
5 | (in-package #:lw2.schema-type)
6 |
7 | (defvar *schema-types* nil)
8 |
9 | (defun delete-schema-type (name)
10 | (setf *schema-types* (delete name *schema-types* :key #'car)))
11 |
12 | (defmacro undefine-schema-type (name)
13 | `(eval-when (:compile-toplevel :load-toplevel :execute)
14 | (delete-schema-type ,name)))
15 |
16 | (defmacro define-schema-type (name options fields)
17 | (declare (ignore options))
18 | `(eval-when (:compile-toplevel :load-toplevel :execute)
19 | (delete-schema-type ,name)
20 | (setf *schema-types*
21 | (acons ,name (alist :fields ',fields)
22 | *schema-types*))))
23 |
24 | (defun find-schema-type (schema-type-name)
25 | (let ((c (assoc schema-type-name *schema-types*)))
26 | (if c
27 | (cdr c)
28 | (error "Undefined schema-type: ~A" schema-type-name))))
29 |
30 | (defmacro schema-bind ((schema-type-name datum bindings &key context) &body body)
31 | (let* ((schema-type (find-schema-type schema-type-name))
32 | (fields (cdr (assoc :fields schema-type))))
33 | `(alist-bind
34 | ,(loop with added = (make-hash-table :test 'eq)
35 | for type-field in fields
36 | nconc (destructuring-bind (binding-sym type &key alias ((:context field-context)) &allow-other-keys) type-field
37 | (when (and (not (gethash binding-sym added))
38 | (if (eq bindings :auto)
39 | (or (not field-context) (eq field-context context))
40 | (member binding-sym bindings :test #'string=)))
41 | (setf (gethash binding-sym added) t)
42 | (list (list* (intern (string binding-sym) *package*)
43 | (if (eq type 'string) 'simple-string type) ; Optimization, assuming strings coming from the backend
44 | ; can never be displaced etc.
45 | (if alias (list alias)))))))
46 | ,datum
47 | ,@body)))
48 |
--------------------------------------------------------------------------------
/src/sites.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.sites
2 | (:use #:cl #:lw2.utils #:lw2.context #:lw2.routes #:lw2.backend-modules #:lw2.fonts-modules)
3 | (:import-from #:sb-ext #:defglobal)
4 | (:export
5 | #:*sites*
6 | #:site #:forum-site #:wiki-site
7 | #:login-site #:basic-login-site #:oidc-login-site
8 | #:shortform-site #:ignore-list-site
9 | #:alternate-frontend-site #:lw2-frontend-site #:lesswrong-viewer-site #:ea-forum-viewer-site
10 | #:progress-forum-viewer-site
11 | #:arbital-site
12 | #:site-extended-vote-style
13 | #:site-class #:call-route-handler #:site-class-routes
14 | #:site-uri #:site-host #:site-domain #:site-link-base #:site-secure #:site-backend #:site-title #:site-description #:background-loader-enabled #:site-fonts-source
15 | #:main-site-title #:main-site-abbreviation #:main-site-uri #:always-canonical
16 | #:host-matches #:find-site
17 | #:call-with-site-context #:with-site-context
18 | #:reset-site-definitions
19 | #:define-site
20 | #:define-route))
21 |
22 | (in-package #:lw2.sites)
23 |
24 | (defglobal *sites* nil)
25 |
26 | (defclass site-class (standard-class)
27 | ((routes :accessor site-class-routes :initform nil)))
28 |
29 | (defmethod closer-mop:validate-superclass ((c site-class) (sc standard-class))
30 | t)
31 |
32 | (defmethod site-class-routes ((c t))
33 | nil)
34 |
35 | (defmethod call-route-handler ((original-class site-class) request-uri)
36 | (dolist (class (closer-mop:class-precedence-list original-class))
37 | (dolist (route (site-class-routes class))
38 | (when (execute-route route request-uri)
39 | (return-from call-route-handler t)))))
40 |
41 | (defclass site ()
42 | ((uri :accessor site-uri :initarg :uri :type simple-string)
43 | (host :accessor site-host :initarg :host :type simple-string)
44 | (domain :accessor site-domain :initarg :domain :initform nil)
45 | (secure :accessor site-secure :initarg :secure)
46 | (title :accessor site-title :initarg :title :type simple-string)
47 | (description :accessor site-description :initarg :description :type simple-string)
48 | (fonts-source :accessor site-fonts-source :initarg :fonts-source :initform (make-instance 'google-fonts-source) :type fonts-source))
49 | (:metaclass site-class))
50 |
51 | (defmethod main-site-title ((s site)) nil)
52 |
53 | (defmethod main-site-abbreviation ((s site)) nil)
54 |
55 | (defmethod site-link-base ((s site)) (site-uri s))
56 |
57 | (defmethod always-canonical ((s site)) nil)
58 |
59 | (defmethod call-route-handler ((s site) request-uri)
60 | (call-route-handler (class-of s) request-uri))
61 |
62 | (defclass backend-site (site)
63 | ((backend :accessor site-backend :initarg :backend :type backend-base)
64 | (background-loader-enabled :accessor background-loader-enabled :initarg :use-background-loader :initform nil :type boolean))
65 | (:metaclass site-class))
66 |
67 | (defclass login-site (backend-site) ()
68 | (:metaclass site-class))
69 |
70 | (defclass forum-site (backend-site) ()
71 | (:metaclass site-class))
72 |
73 | (defclass wiki-site (backend-site) ()
74 | (:metaclass site-class))
75 |
76 | (defclass shortform-site (backend-site) ()
77 | (:metaclass site-class))
78 |
79 | (defclass ignore-list-site (login-site) ()
80 | (:metaclass site-class))
81 |
82 | (defclass alternate-frontend-site (backend-site)
83 | ((main-site-title :accessor main-site-title :initarg :main-site-title :type simple-string)
84 | (main-site-abbreviation :accessor main-site-abbreviation :initarg :main-site-abbreviation :type simple-string)
85 | (main-site-uri :accessor main-site-uri :initarg :main-site-uri :type simple-string)
86 | (always-canonical :accessor always-canonical :initarg :always-canonical :initform nil :type boolean))
87 | (:metaclass site-class))
88 |
89 | (defmethod site-link-base ((s alternate-frontend-site)) (main-site-uri s))
90 |
91 | (defclass lw2-frontend-site (alternate-frontend-site) ()
92 | (:metaclass site-class))
93 |
94 | (defclass lesswrong-viewer-site (forum-site ignore-list-site login-site lw2-frontend-site shortform-site) ()
95 | (:metaclass site-class))
96 |
97 | (defclass ea-forum-viewer-site (forum-site ignore-list-site login-site lw2-frontend-site shortform-site) ()
98 | (:metaclass site-class))
99 |
100 | (defclass progress-forum-viewer-site (forum-site ignore-list-site login-site lw2-frontend-site shortform-site) ()
101 | (:metaclass site-class))
102 |
103 | (defclass arbital-site (wiki-site alternate-frontend-site) ()
104 | (:metaclass site-class))
105 |
106 | (defmethod host-matches ((site site) host)
107 | (let ((site-host (site-host site)))
108 | (and site-host (string-equal site-host host))))
109 |
110 | (defun find-site (host)
111 | (find-if (lambda (site) (host-matches site host))
112 | *sites*))
113 |
114 | (defgeneric site-extended-vote-style (site)
115 | (:method ((site lesswrong-viewer-site)) :lw)
116 | (:method ((site ea-forum-viewer-site)) :ea)
117 | (:method ((site t)) nil))
118 |
119 | (defgeneric call-with-site-context (site request fn)
120 | (:method :around ((site site) (request t) fn)
121 | (let ((*current-site* site)
122 | (*default-last-modified* (load-time-value (get-universal-time))))
123 | (call-next-method)))
124 | (:method ((site site) (request t) fn)
125 | (funcall fn))
126 | (:method ((site backend-site) request fn)
127 | (let* ((backend (site-backend site))
128 | (*current-backend* backend))
129 | (call-with-backend-context backend request #'call-next-method))))
130 |
131 | (defmacro with-site-context ((site &key (request t)) &body body)
132 | `(call-with-site-context ,site ,request (lambda () ,@body)))
133 |
134 | (defun reset-site-definitions ()
135 | (setf *sites* nil))
136 |
137 | (defmacro define-site (&rest args)
138 | (let* ((class 'site)
139 | (args2
140 | (map-plist (lambda (key val)
141 | (cond
142 | ((eq key :class)
143 | (setf class val)
144 | nil)
145 | ((eq key :backend)
146 | (list key `(make-backend ,@val)))
147 | ((eq key :uri)
148 | (let* ((uri (quri:uri val))
149 | (scheme (quri:uri-scheme uri))
150 | (host (quri:uri-host uri))
151 | (port (quri:uri-port uri))
152 | (default-port (quri.port:scheme-default-port scheme)))
153 | (list key val
154 | :host (format nil "~A~@[:~A~]"
155 | host
156 | (if (/= default-port port) port))
157 | :secure (string-equal "https" scheme))))
158 | (t (list key val))))
159 | args)))
160 | `(push (make-instance ',class ,.args2) *sites*)))
161 |
162 | (defun define-route (site-class route-class &rest args)
163 | (let ((new-route (apply #'make-instance route-class args)))
164 | (setf (site-class-routes (find-class site-class))
165 | (cons
166 | new-route
167 | (remove (route-name new-route) (site-class-routes (find-class site-class)) :key #'route-name)))))
168 |
--------------------------------------------------------------------------------
/src/user-context.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.user-context
2 | (:use #:cl)
3 | (:export #:*current-auth-token* #:*current-auth-status* #:*current-userid* #:*current-username* #:*current-user-slug* #:*current-ignore-hash*
4 | #:logged-in-userid #:logged-in-username #:logged-in-user-slug))
5 |
6 | (in-package #:lw2.user-context)
7 |
8 | (defvar *current-auth-token*)
9 | (defvar *current-auth-status*)
10 | (defvar *current-userid*)
11 | (defvar *current-username*)
12 | (defvar *current-user-slug*)
13 | (defvar *current-ignore-hash*)
14 |
15 | (defun logged-in-userid (&optional is-userid)
16 | (let ((current-userid *current-userid*))
17 | (if is-userid
18 | (string= current-userid is-userid)
19 | current-userid)))
20 |
21 | (defun logged-in-username ()
22 | *current-username*)
23 |
24 | (defun logged-in-user-slug ()
25 | *current-user-slug*)
26 |
--------------------------------------------------------------------------------
/src/web-push.lisp:
--------------------------------------------------------------------------------
1 | (uiop:define-package #:lw2.web-push
2 | (:use #:cl #:alexandria #:lw2.utils #:lw2.conditions)
3 | (:export #:get-vapid-public-key #:send-notification))
4 |
5 | (in-package #:lw2.web-push)
6 |
7 | (defparameter *vapid-key-filename* (asdf:system-relative-pathname :lw2-viewer "webpush.vapid.key"))
8 | (sb-ext:defglobal *vapid-key* nil)
9 | (sb-ext:defglobal *vapid-header-cache* (make-hash-table :test 'equal))
10 | (sb-ext:defglobal *vapid-header-cache-lock* (sb-thread:make-mutex :name "vapid header cache lock"))
11 |
12 | (defun call-with-private-file (fn name)
13 | (let ((fd nil))
14 | (unwind-protect
15 | (progn
16 | (setf fd (sb-posix:open name (logior sb-posix:o-creat sb-posix:o-rdwr) #o600))
17 | (funcall fn (sb-sys:make-fd-stream fd :input t :output t)))
18 | (when fd (sb-posix:close fd)))))
19 |
20 | (defun invoke-node-process (command &optional (output #'json:decode-json))
21 | (uiop:run-program "node js-foreign-lib/web-push.js"
22 | :input (list command)
23 | :output output
24 | :error-output *error-output*))
25 |
26 | (defun ensure-vapid-key ()
27 | (unless *vapid-key*
28 | (labels ((read-vapid-key (stream)
29 | (setf *vapid-key* (json:decode-json stream))))
30 | (log-and-ignore-errors
31 | (with-open-file (stream *vapid-key-filename* :direction :input :if-does-not-exist nil)
32 | (if stream
33 | (read-vapid-key stream)
34 | (call-with-private-file (lambda (stream)
35 | (invoke-node-process "webPush.generateVAPIDKeys()" stream)
36 | (file-position stream 0)
37 | (read-vapid-key stream))
38 | *vapid-key-filename*)))))))
39 |
40 | (ensure-vapid-key)
41 |
42 | (defun get-vapid-public-key ()
43 | (cdr (assoc :public-key *vapid-key*)))
44 |
45 | (defun generate-vapid-headers (origin)
46 | (let* ((result-json
47 | (invoke-node-process
48 | (format nil "webPush.getVapidHeaders(~{~A~^,~});"
49 | (mapcar #'json:encode-json-to-string
50 | (list origin "mailto:test@example.com"
51 | (cdr (assoc :public-key *vapid-key*)) (cdr (assoc :private-key *vapid-key*)) "aes128gcm")))))
52 | (result-string (cdar result-json))
53 | (result-parts (nth-value 1
54 | (ppcre:scan-to-strings "vapid t=([^,]+), k=([^,]+)" result-string))))
55 | (assert (= (length result-parts) 2))
56 | (alist :authorization (format nil "WebPush ~A" (aref result-parts 0))
57 | :crypto-key (format nil "p256ecdsa=~A" (aref result-parts 1)))))
58 |
59 | (defun get-vapid-headers (origin)
60 | (let ((unlocked-value
61 | (sb-thread:with-mutex (*vapid-header-cache-lock*)
62 | (let ((value (gethash origin *vapid-header-cache*))
63 | (current-time (get-unix-time)))
64 | (if (and value (< current-time (+ (car value) (* 60 60 12))))
65 | (cdr value)
66 | (setf (gethash origin *vapid-header-cache*)
67 | (sb-thread:make-thread (lambda ()
68 | (let ((vapid (generate-vapid-headers origin)))
69 | (sb-thread:with-mutex (*vapid-header-cache-lock*)
70 | (setf (gethash origin *vapid-header-cache*) (cons current-time vapid)))
71 | vapid))
72 | :name "generate vapid headers")))))))
73 | (typecase unlocked-value
74 | (sb-thread:thread (sb-thread:join-thread unlocked-value))
75 | (t unlocked-value))))
76 |
77 | (defun send-notification (endpoint &key (ttl (* 60 60 24)))
78 | ;; we don't support content yet since it requires encryption
79 | (let* ((endpoint-uri (quri:uri endpoint))
80 | (origin (concatenate 'string (quri:uri-scheme endpoint-uri) "://" (quri:uri-authority endpoint-uri)))
81 | (headers (alist* :ttl ttl
82 | :content-encoding "identity"
83 | (get-vapid-headers origin))))
84 | (dex:request endpoint
85 | :method :post
86 | :headers headers
87 | :keep-alive nil)))
88 |
--------------------------------------------------------------------------------
/templates/conversation.html:
--------------------------------------------------------------------------------
1 | {% if conversation %}
2 |
{{ conversation.title }}
3 |
6 | {% else %}
7 | Send private message
8 | {% endif %}
9 |
30 |
--------------------------------------------------------------------------------
/templates/edit-post.html:
--------------------------------------------------------------------------------
1 |
41 |
--------------------------------------------------------------------------------
/templates/reset-password.html:
--------------------------------------------------------------------------------
1 |
2 |
Reset password
3 |
Step 1
4 | {% if message and step == 1 %}
{{ message }}
{% endif %}
5 |
Request a password reset link.
6 |
12 |
Step 2
13 | {% if message and step == 2 %}
{{ message }}
{% endif %}
14 |
If your browser is capable of viewing LW 2.0, you can simply follow the instructions in the email.
16 |
23 |
10 |
12 |
19 |
23 |
24 |
27 |
30 |
62 |
72 |
73 |
--------------------------------------------------------------------------------
/www/assets/rss.svg:
--------------------------------------------------------------------------------
1 |
2 |
3 |
19 |
--------------------------------------------------------------------------------
/www/assets/telegraph.jpg:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/telegraph.jpg
--------------------------------------------------------------------------------
/www/assets/theme_A.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_A.gif
--------------------------------------------------------------------------------
/www/assets/theme_B.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_B.gif
--------------------------------------------------------------------------------
/www/assets/theme_C.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_C.gif
--------------------------------------------------------------------------------
/www/assets/theme_D.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_D.gif
--------------------------------------------------------------------------------
/www/assets/theme_E.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_E.gif
--------------------------------------------------------------------------------
/www/assets/theme_F.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_F.gif
--------------------------------------------------------------------------------
/www/assets/theme_G.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_G.gif
--------------------------------------------------------------------------------
/www/assets/theme_H.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/theme_H.gif
--------------------------------------------------------------------------------
/www/assets/up-arrow-blue-on-white.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/up-arrow-blue-on-white.gif
--------------------------------------------------------------------------------
/www/assets/up-arrow-white-on-blue.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kronusaturn/lw2-viewer/48581f610f099df49201a38e60ac7e6fa1cd63c3/www/assets/up-arrow-white-on-blue.gif
--------------------------------------------------------------------------------
/www/assets/vote_button_icons/agree-black-square-check.svg:
--------------------------------------------------------------------------------
1 |