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)
11 (lambda () (json:decode-json-from-string json-string
)))))
13 (string (if (string= result
"not-found")
14 (error 'lw2-not-found-error
)
15 (error "Unknown error.")))
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
))
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
)
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
))))))
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")
51 (declare (ignore status uri
))
52 (cond ((string= (gethash "content-type" headers
) "application/json")
54 ((string= result
"Couldn't find page")
55 (return "\"not-found\"")))))
58 (data (decode-arbital-json json-string
)))
59 (update-arbital-aliases data
)
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")
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
))
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
))))
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
)
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
)
116 (format nil
"<span class=\"arbital-math\">\\(~A\\)</span>" (reg 0)))))
117 (markdown (regex-replace-body ("(?<!\\\\)\\[([-+]?)([^] ]*)(?: ([^]]*?))?\\](?!\\()" markdown
)
118 (let ((capitalization-char (reg 0))
121 (labels ((recapitalize (string)
122 (cond ((string= capitalization-char
"+") (string-upcase string
:end
1))
123 ((string= capitalization-char
"-") (string-downcase string
))
126 ((ppcre:scan
"^http" tag
)
127 (markdown-protect-wrap
128 (format nil
"<a href=\"~A\">" (encode-entities tag
))
129 (or text
(recapitalize tag
))
131 ((ppcre:scan
":$" tag
)
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
))))
140 (markdown-protect-wrap
141 (format nil
"<span class=\"redlink\" title=\"~A\">" (encode-entities tag
))
142 (or text
(recapitalize (regex-replace-all "_" tag
" ")))
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
)
150 (alexandria:switch
(type :test
#'string
=)
152 (markdown-protect-wrap
153 "<span class=\"arbital-note-marker\">note<span class=\"arbital-note\">"
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
))
163 (incf expand-counter
)))
166 (markdown-protect "<div class=\"arbital-special-block\"><span class=\"arbital-block-type\">")
168 (if param
(format nil
"(~A)" param
) "")
169 (markdown-protect ": </span>")
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
))
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
)))
187 (multiple-value-bind (pretty-time js-time
) (pretty-time (cdr (assoc :page-created-at page-data
)) :loose-parsing t
)
190 <a class
="date" href
=("#comment-~A" (cdr (assoc :page-id page-data
))) data-js-date
=js-time
>
192 (safe (pretty-time-js))
195 <span class
="date" data-js-date
=js-time
>
197 (safe (pretty-time-js))
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
)))
209 (sb-ext:timeout
() nil
)))
210 (page-data (cdr (assoc
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
))
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
>)
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
)))
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
)
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
))
239 <div class
="post-meta bottom-post-meta">
240 (arbital-meta-block page-data all-data
:page
)
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
247 ((list-pages (page-list)
249 (dolist (c page-list
)
250 (let ((page-data (cdr (assoc c
(cdr (assoc :pages all-data
)) :test
#'string
=))))
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
))
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
)))))
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
)
276 <div class
="comment-body body-text">
277 (with-html-stream-output
278 (arbital-markdown-to-html (cdr (assoc :text comment-data
)) *html-output
*))
281 (when-let (comment-list (cdr (assoc :comment-ids comment-data
)))
282 (arbital-comments comment-list
(1+ depth
)))
285 (when-let (comment-list (cdr (assoc :comment-ids page-data
)))
286 (arbital-comments comment-list
0)))
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
)))