arbital.lisp

   1 (in-package #:lw2.backend)
   2
   3 (define-cache-database 'backend-arbital "page-body-json" "page-body-json-meta" "alias-to-lens-id")
   4
   5 (eval-when (:compile-toplevel :load-toplevel :execute)
   6   (export 'get-page-body))
   7
   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))))
  17
  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))))))
  28
  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)))))))
  64
  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)))))
  74
  75 (in-package #:lw2-viewer)
  76
  77 (named-readtables:in-readtable html-reader)
  78
  79 (defvar *arbital-context*)
  80
  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")))
  85
  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")))))
  92
  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)))
  97
  98 (defparameter *markdown-replace-string* "ouNi5iej")
  99
 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 ""))
 133                              (t
 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)))
 164                            (t
 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))))))
 180
 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>)
 194       (t
 195        <span class="date" data-js-date=js-time>
 196          (progn pretty-time)
 197          (safe (pretty-time-js))
 198        </span>))))
 199
 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>)))))
 288
 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)))