Merge branch 'master' into next
[lw2-viewer.git] / arbital.lisp
blob452966f085e0df40459081fd791fc788ec13b7bb
1 (in-package #:lw2.backend)
3 (define-cache-database 'backend-arbital "page-body-json" "page-body-json-meta" "alias-to-lens-id")
5 (eval-when (:compile-toplevel :load-toplevel :execute)
6 (export 'get-page-body))
8 (defun decode-arbital-json (json-string)
9 (let ((result
10 (call-with-safe-json
11 (lambda () (json:decode-json-from-string json-string)))))
12 (typecase result
13 (string (if (string= result "not-found")
14 (error 'lw2-not-found-error)
15 (error "Unknown error.")))
16 (t result))))
18 (defun update-arbital-aliases (data)
19 (with-cache-transaction
20 (dolist (page-data (cdr (assoc :pages data)))
21 (let* ((lens-id (car page-data))
22 (lens-id (typecase lens-id
23 (symbol (string-downcase lens-id))
24 (t lens-id)))
25 (page-alias (cdr (assoc :alias (cdr page-data)))))
26 (when (and (> (length lens-id) 0) (> (length page-alias) 0))
27 (cache-put "alias-to-lens-id" page-alias lens-id))))))
29 (define-backend-function get-page-body (params page-type)
30 (backend-arbital
31 (let* ((query (json:encode-json-to-string params))
32 (page-key (case page-type
33 (:explore (cdr (assoc :page-alias params)))
34 (t (or (cdr (assoc :lens-id params))
35 (cache-get "alias-to-lens-id" (cdr (assoc :page-alias params)))
36 (cdr (assoc :page-alias params))))))
37 (fn (lambda ()
38 (let* ((json-string
39 (block nil
40 (loop
41 (handler-case
42 (sb-sys:with-deadline (:seconds 600 :override t)
43 (multiple-value-bind (result status headers uri)
44 (dex:request (case page-type
45 (:explore "https://arbital.com/json/explore/")
46 (t "https://arbital.com/json/primaryPage/"))
47 :headers (alist "content-type" "application/json")
48 :method :post
49 :content query
50 :keep-alive nil)
51 (declare (ignore status uri))
52 (cond ((string= (gethash "content-type" headers) "application/json")
53 (return result))
54 ((string= result "Couldn't find page")
55 (return "\"not-found\"")))))
56 (t () nil))
57 (sleep 2))))
58 (data (decode-arbital-json json-string)))
59 (update-arbital-aliases data)
60 json-string))))
61 (call-with-safe-json
62 (lambda ()
63 (lw2-graphql-query-timeout-cached fn "page-body-json" (format nil "~@[~A ~]~A" (unless (eq page-type :primary-page) page-type) page-key)))))))
65 (defun add-arbital-scrape-files (directory)
66 (with-cache-transaction
67 (dolist (filename (uiop:directory-files directory))
68 (let* ((file-string (uiop:read-file-string filename))
69 (file-data (decode-arbital-json file-string)))
70 (cache-put "page-body-json"
71 (ppcre:regex-replace "^.*/([^/]+).json$" (namestring filename) "\\1")
72 file-string)
73 (update-arbital-aliases file-data)))))
75 (in-package #:lw2-viewer)
77 (named-readtables:in-readtable html-reader)
79 (defvar *arbital-context*)
81 (defmethod site-resources append ((site arbital-site))
82 (list
83 (list :stylesheet (generate-versioned-link "/arbital.css"))
84 (list :async-script "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-MML-AM_CHTML")))
86 (defmethod site-nav-bars ((site arbital-site))
87 '((:secondary-bar (("about" "/about" "About" :accesskey "t")))
88 (:primary-bar (("home" "/" "Home" :accesskey "h")
89 ("math" "/explore/math/" "Math")
90 ("ai-alignment" "/explore/ai_alignment/" "AI Alignment")
91 ("meta" "/explore/Arbital/" "Arbital")))))
93 (define-lmdb-memoized markdown-to-html 'lw2.backend-modules:backend-arbital
94 (:sources ("js-foreign-lib/convert.js")) (markdown-string)
95 (with-input-from-string (stream markdown-string)
96 (uiop:run-program "node js-foreign-lib/convert.js" :input stream :output :string)))
98 (defparameter *markdown-replace-string* "ouNi5iej")
100 (defun arbital-markdown-to-html (markdown stream)
101 (let ((replacements (make-array 0 :adjustable t :fill-pointer t)))
102 (labels ((markdown-protect (x)
103 (prog1 (format nil "~A-~A-" *markdown-replace-string* (fill-pointer replacements))
104 (vector-push-extend x replacements)))
105 (markdown-protect-wrap (a b c)
106 (concatenate 'string (markdown-protect a) b (markdown-protect c))))
107 (let*
108 ((expand-counter 0)
109 (markdown (regex-replace-all (ppcre:create-scanner "(?<=\\S )\\*(?= )" :single-line-mode t) markdown "\\\\*"))
110 (markdown (regex-replace-all (ppcre:create-scanner "^\\[.?summary(?:\\(.*?\\))?:.*?\\]$" :single-line-mode t :multi-line-mode t) markdown ""))
111 (markdown (regex-replace-body ((ppcre:create-scanner "^\\$\\$(.+?)\\$\\$$" :single-line-mode t :multi-line-mode t) markdown)
112 (markdown-protect
113 (format nil "<div class=\"arbital-math\">$$~A$$</div>" (reg 0)))))
114 (markdown (regex-replace-body ((ppcre:create-scanner "(?:(?<=\\s)|^)\\$(.+?)(?<!\\\\)\\$" :multi-line-mode t) markdown)
115 (markdown-protect
116 (format nil "<span class=\"arbital-math\">\\(~A\\)</span>" (reg 0)))))
117 (markdown (regex-replace-body ("(?<!\\\\)\\[([-+]?)([^] ]*)(?: ([^]]*?))?\\](?!\\()" markdown)
118 (let ((capitalization-char (reg 0))
119 (tag (reg 1))
120 (text (reg 2)))
121 (labels ((recapitalize (string)
122 (cond ((string= capitalization-char "+") (string-upcase string :end 1))
123 ((string= capitalization-char "-") (string-downcase string))
124 (t string))))
125 (cond
126 ((ppcre:scan "^http" tag)
127 (markdown-protect-wrap
128 (format nil "<a href=\"~A\">" (encode-entities tag))
129 (or text (recapitalize tag))
130 "</a>"))
131 ((ppcre:scan ":$" tag)
132 (or text ""))
134 (let ((page-data (cdr (assoc tag *arbital-context* :test #'string=))))
135 (if-let (page-alias (cdr (assoc :alias page-data)))
136 (markdown-protect-wrap
137 (format nil "<a href=\"/p/~A~@[?l=~A~]\">" (encode-entities page-alias) (encode-entities tag))
138 (or text (recapitalize (cdr (assoc :title page-data))))
139 "</a>")
140 (markdown-protect-wrap
141 (format nil "<span class=\"redlink\" title=\"~A\">" (encode-entities tag))
142 (or text (recapitalize (regex-replace-all "_" tag " ")))
143 "</span>")))))))))
144 (markdown (regex-replace-body (#'url-scanner markdown)
145 (markdown-protect (match))))
146 (markdown (regex-replace-body ((ppcre:create-scanner "(%+)([^ ]*?)(?:\\(([^)]*)\\))?: ?(.*?)\\1" :single-line-mode t) markdown)
147 (let ((type (reg 1))
148 (param (reg 2))
149 (text (reg 3)))
150 (alexandria:switch (type :test #'string=)
151 ("note"
152 (markdown-protect-wrap
153 "<span class=\"arbital-note-marker\">note<span class=\"arbital-note\">"
154 text
155 "</span></span>"))
156 ("hidden"
157 (prog1
158 (markdown-protect-wrap
159 (format nil "<div class=\"arbital-hidden\"><input type=\"checkbox\" id=\"expand-~A\"><label for=\"expand-~@*~A\">~A</label><div>"
160 expand-counter (encode-entities param))
161 text
162 "</div></div>")
163 (incf expand-counter)))
165 (concatenate 'string
166 (markdown-protect "<div class=\"arbital-special-block\"><span class=\"arbital-block-type\">")
167 type
168 (if param (format nil "(~A)" param) "")
169 (markdown-protect ": </span>")
170 text
171 (markdown-protect "</div>")))))))
172 (markdown (regex-replace-all "\\\\\\$" markdown "$"))
173 (html (regex-replace-body ((load-time-value (format nil "~A-(\\d+)-" *markdown-replace-string*))
174 (markdown-to-html markdown))
175 (let ((replacement-index-string (reg 0)))
176 (if replacement-index-string
177 (aref replacements (parse-integer replacement-index-string))
178 "")))))
179 (let ((*memoized-output-stream* stream)) (clean-html* html :with-toc t))))))
181 (defun arbital-meta-block (page-data all-data type)
182 (let* ((creator-id (cdr (assoc :page-creator-id page-data)))
183 (user (cdr (assoc creator-id (cdr (assoc :users all-data)) :test #'string=))))
184 <a class="author" href=("/p/~A" creator-id) data-userid=creator-id>
185 (format nil "~{~A~^ ~}" (map 'list (lambda (x) (cdr (assoc x user))) '(:first-name :last-name)))
186 </a>)
187 (multiple-value-bind (pretty-time js-time) (pretty-time (cdr (assoc :page-created-at page-data)) :loose-parsing t)
188 (cond
189 ((eq type :comment)
190 <a class="date" href=("#comment-~A" (cdr (assoc :page-id page-data))) data-js-date=js-time>
191 (safe pretty-time)
192 (safe (pretty-time-js))
193 </a>)
195 <span class="date" data-js-date=js-time>
196 (progn pretty-time)
197 (safe (pretty-time-js))
198 </span>))))
200 (define-component view-arbital-page (id page-alias page-type)
201 (:http-args ((l :type (or string null))))
202 (let* ((id (or id l))
203 (all-data (handler-case
204 (sb-sys:with-deadline (:seconds 0.3)
205 (lw2.backend:get-page-body (list-cond
206 (page-alias (cons :page-alias page-alias))
207 (id (cons :lens-id id)))
208 page-type))
209 (sb-ext:timeout () nil)))
210 (page-data (cdr (assoc
211 (or id
212 (cdr (assoc :page-id (cdr (assoc :result all-data))))
213 (cdr (assoc :primary-page-id (cdr (assoc :result all-data)))))
214 (cdr (assoc :pages all-data))
215 :test #'string=))))
216 (renderer ()
217 (unless all-data
218 (emit-page (*html-output* :title "Loading" :content-class "loading-page" :return-code 504
219 :extra-head (lambda () (format *html-output* "<meta http-equiv=\"refresh\" content=\"5\">")))
220 <h1>One moment...</h1>
221 <img src="/assets/telegraph.jpg">
222 <p>Loading data from Arbital, please be patient...</p>)
223 (return nil))
224 (let ((*arbital-context* (cdr (assoc :pages all-data))))
225 (emit-page (*html-output* :title (format nil "~:[~;Explore: ~]~A" (eq page-type :explore) (cdr (assoc :title page-data)))
226 :social-description (cdr (assoc :clickbait page-data)))
227 <main class="post">
228 <h1 class="post-title">(cdr (assoc :title page-data))</h1>
229 <div class="post-meta top-post-meta">
230 (arbital-meta-block page-data all-data :page)
231 </div>
232 (when (and (cdr (assoc :text page-data)) (> (length (cdr (assoc :text page-data))) 0))
233 <div class="body-text post-body">
234 (with-html-stream-output
235 (when (assoc :text page-data)
236 (arbital-markdown-to-html (cdr (assoc :text page-data))
237 *html-output*)))
238 </div>
239 <div class="post-meta bottom-post-meta">
240 (arbital-meta-block page-data all-data :page)
241 </div>)
242 <div class="arbital-nav page-list-index">
243 (dolist (page-list-data '((:child-ids "Children")
244 (:parent-ids "Parents")))
245 (destructuring-bind (page-list-id page-list-name) page-list-data
246 (labels
247 ((list-pages (page-list)
248 <ul>
249 (dolist (c page-list)
250 (let ((page-data (cdr (assoc c (cdr (assoc :pages all-data)) :test #'string=))))
251 <li>
252 <a href=("/p/~A~@[?l=~A~]" (cdr (assoc :alias page-data)) c)>(cdr (assoc :title page-data))</a>
253 (with-html-stream-output
254 (when-let (clickbait (cdr (assoc :clickbait page-data)))
255 (arbital-markdown-to-html clickbait *html-output*)))
256 (when-let (page-list (cdr (assoc page-list-id page-data)))
257 (list-pages page-list))
258 </li>))
259 </ul>))
260 (when-let (page-list (cdr (assoc page-list-id page-data)))
261 (unless (eq page-type :explore)
262 <p>(progn page-list-name):</p>)
263 (list-pages page-list)))))
264 </div>
265 </main>
266 <div class="comments" id="comments">
267 (labels ((arbital-comments (comment-list depth)
268 <ul class="comment-thread">
269 (dolist (c comment-list)
270 (let ((comment-data (cdr (assoc c (cdr (assoc :pages all-data)) :test #'string=))))
271 <li class=("comment-item ~A" (if (evenp depth) "depth-odd" "depth-even")) id=("#comment-~A" (cdr (assoc :page-id comment-data)))>
272 <div class="comment">
273 <div class="comment-meta">
274 (arbital-meta-block comment-data all-data :comment)
275 </div>
276 <div class="comment-body body-text">
277 (with-html-stream-output
278 (arbital-markdown-to-html (cdr (assoc :text comment-data)) *html-output*))
279 </div>
280 </div>
281 (when-let (comment-list (cdr (assoc :comment-ids comment-data)))
282 (arbital-comments comment-list (1+ depth)))
283 </li>))
284 </ul>))
285 (when-let (comment-list (cdr (assoc :comment-ids page-data)))
286 (arbital-comments comment-list 0)))
287 </div>)))))
289 (define-component-routes arbital-site
290 (view-arbital-root (standard-route :uri "/") () (view-arbital-page nil "84c" :primary-page))
291 (view-arbital-page (regex-route :regex "/p/([^/]+)") (page-alias) (view-arbital-page nil page-alias :primary-page))
292 (view-arbital-explore (regex-route :regex "/explore/([^/]+)") (page-alias) (view-arbital-page nil page-alias :explore)))