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 arbital-site) link)
  47   (ppcre:scan "^https?://(?:www\\.)?(?:arbital\\.com)" link))
  48
  49 (defun find-link-site (link)
  50   (if (ppcre:scan "^/(?!/)" link)
  51       *current-site*
  52       (loop for s in *sites*
  53          when (link-for-site-p s link) return s)))
  54
  55 (defun site-link-prefix (site)
  56   (if (eq site *current-site*)
  57       "/"
  58       (site-uri site)))
  59
  60 (defun match-lw1-link (link) (match-values "(?:^https?://(?:www.)?less(?:er|est)?wrong.com|^)(?:/r/discussion|/r/lesswrong|/r/all)?(/lw/.*)" link (0)))
  61
  62 (defun match-ea1-link (link) (match-values "^(?:https?://(?:www\\.)?(?:effective-altruism\\.com|forum\\.effectivealtruism\\.org))?(/ea/.*)" link (0)))
  63
  64 (defun match-agentfoundations-link (link) (match-values "^(?:https?://(?:www\\.)?agentfoundations\\.org)?(/item\\?id=.*)" link (0)))
  65
  66 (defun match-lw2-link (link) (match-values "^(?:https?://[^/]+)?/(post|event)s/([^/]+)(?:/([^/#?]*)(?:/(comment|answer)/([^/#?]+)|/?(?:#(?:comment-)?|\\?commentId=)([^/#]+))?)?" link (1 (or 4 5) 2 3 0)))
  67
  68 (defun match-lw2-slug-link (link) (match-values "^(?:https?://(?:www.)?less(?:er|est)?wrong.com)?/(?:codex|hpmor)/([^/#]+)(?:/?#?([^/#]+)?)?" link (0 1)))
  69
  70 (defun match-lw2-sequence-link (link) (match-values "^(?:https?://[^/]+)?/s/([^/#]+)(?:/p/([^/#]+))?(?:#([^/#]+)?)?" link (0 1 2)))
  71
  72 (defun convert-lw2-misc-link (link)
  73   (when-let* ((site (find-link-site link))
  74               (matched-link (and (typep site '(or lesswrong-viewer-site ea-forum-viewer-site)) (match-values "^(?:https?://[^/]+)?/((?:users/|tags|tag/|topics/|s/|sequences/|library).*)" link (0)))))
  75     (concatenate 'string (site-link-prefix site) matched-link)))
  76
  77 (defun convert-arbital-link (link)
  78   (when-let* ((site (find-link-site link))
  79               (matched-link (and (typep site 'arbital-site) (match-values "^(?:https?://[^/]+)?/(.*)" link (0)))))
  80     (concatenate 'string (site-link-prefix site) matched-link)))
  81
  82 (defmacro with-direct-link-restart ((direct-link) &body body)
  83   (once-only (direct-link)
  84     `(restart-case (progn ,@body)
  85        (direct-link () :report "Use direct link." ,direct-link))))
  86
  87 (defun direct-link (&optional c)
  88   (declare (ignore c))
  89   (if-let (restart (find-restart 'direct-link))
  90     (invoke-restart restart)))
  91
  92 (defmacro with-direct-link (&body body)
  93   `(handler-bind
  94      ((serious-condition #'direct-link))
  95      (progn ,@body)))
  96
  97 (defun process-redirect-link (link base-uri site-name)
  98   (if-let ((location (get-redirect (concatenate 'string base-uri link))))
  99           (let ((loc-uri (quri:uri location))) (format nil "~A~@[#comment-~A~]" (quri:uri-path loc-uri) (quri:uri-fragment loc-uri)))
 100           (error "<p>Could not retrieve ~A link.</p><p>You may wish to try <a href='~A'>~:*~A</a>" site-name (concatenate 'string base-uri link))))
 101
 102 (defun convert-redirect-link (link match-fn get-fn base-uri)
 103   (if-let (matched-link (funcall match-fn link))
 104       (with-direct-link-restart ((concatenate 'string base-uri matched-link))
 105         (merge-uris (funcall get-fn matched-link)
 106                     (site-uri (find-link-site base-uri))))))
 107
 108 (simple-cacheable ("lw1-link" 'backend-lmdb-cache "lw1-link" link :catch-errors nil)
 109   (process-redirect-link link "https://www.lesswrong.com" "LessWrong 1.0"))
 110
 111 (defun convert-lw1-link (link)
 112   (convert-redirect-link link #'match-lw1-link #'get-lw1-link "https://www.lesswrong.com"))
 113
 114 (simple-cacheable ("ea1-link" 'backend-lmdb-cache "ea1-link" link :catch-errors nil)
 115   (process-redirect-link link "https://forum.effectivealtruism.org" "EA Forum 1.0"))
 116
 117 (defun convert-ea1-link (link)
 118   (convert-redirect-link link #'match-ea1-link #'get-ea1-link "https://forum.effectivealtruism.org"))
 119
 120 (defun match-overcomingbias-link (link)
 121   (if (ppcre:scan "^https?://(?:www\\.)?overcomingbias\\.com/" link)
 122       link
 123       nil))
 124
 125 (simple-cacheable ("overcomingbias-link" 'backend-lmdb-cache "overcomingbias-link" link :catch-errors nil)
 126   (if-let ((location (get-redirect link)))
 127           (match-lw1-link location)
 128           ""))
 129
 130 (defun convert-overcomingbias-link (link)
 131   (when (match-overcomingbias-link link)
 132     (with-direct-link-restart (link)
 133       (let ((lw1-link (get-overcomingbias-link link)))
 134         (if (string= lw1-link "")
 135             nil
 136             (convert-lw1-link lw1-link))))))
 137
 138 (simple-cacheable ("agentfoundations-link" 'backend-lmdb-cache "agentfoundations-link" link :catch-errors nil)
 139   (process-redirect-link link "https://www.lesswrong.com" "Agent Foundations"))
 140
 141 (defun convert-agentfoundations-link (link)
 142   (convert-redirect-link link #'match-agentfoundations-link #'get-agentfoundations-link "https://www.lesswrong.com"))
 143
 144 (defun gen-internal (post-id slug comment-id &optional absolute-uri stream item-subtype)
 145   (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))
 146
 147 (defun convert-lw2-slug-link (link)
 148   (multiple-value-bind (slug comment-id) (match-lw2-slug-link link)
 149     (when slug
 150       (gen-internal (get-slug-postid slug) slug comment-id))))
 151
 152 (defun convert-lw2-sequence-link (link)
 153   (if-let (site (find-link-site link))
 154           (multiple-value-bind (sequence-id post-id comment-id) (match-lw2-sequence-link link)
 155             (cond
 156               (post-id (gen-internal post-id (get-post-slug post-id) comment-id (site-link-prefix site)))
 157               (sequence-id (format nil "~As/~A" (site-link-prefix site) sequence-id))))))
 158
 159 (defun convert-lw2-link (link)
 160   (multiple-value-bind (post-id comment-id slug) (match-lw2-link link)
 161     (when post-id
 162       (if-let (site (find-link-site link))
 163               (gen-internal post-id slug comment-id (site-link-prefix site))))))
 164
 165 (defun generate-item-link (item-type item-designator &key comment-id absolute stream item-subtype)
 166   (let ((absolute (if (eq absolute t) (site-uri *current-site*) absolute)))
 167     (ecase item-type
 168       (:post
 169        (typecase item-designator
 170          (string
 171           (gen-internal item-designator (get-post-slug item-designator) comment-id absolute stream (or item-subtype "post")))
 172          (cons
 173           (let ((post-id (cdr (assoc :--id item-designator))))
 174             (gen-internal post-id (or (cdr (assoc :slug item-designator)) (get-post-slug post-id)) comment-id absolute stream (or item-subtype "post"))))))
 175       (:tag
 176        (with-output-to-designator (out stream)
 177          (format out "~Atag/~A~@[#comment-~A~]" (or absolute "/") item-designator comment-id))))))
 178
 179 (defun convert-any-link* (url)
 180   (let ((url (sanitize-link url)))
 181     (or (convert-lw2-link url)
 182         (convert-lw2-slug-link url)
 183         (convert-lw2-sequence-link url)
 184         (convert-lw1-link url)
 185         (convert-ea1-link url)
 186         (convert-agentfoundations-link url)
 187         (convert-overcomingbias-link url)
 188         (convert-lw2-misc-link url)
 189         (convert-arbital-link url))))
 190
 191 (defun convert-any-link (url)
 192   (or (convert-any-link* url) url))
 193
 194 (defun presentable-link (link &optional context)
 195   (or (and (ppcre:scan "^#" link) link)
 196       (and (not (eq context :image)) (convert-any-link* link))
 197       (and (not (eq context :search))
 198            (let ((sanitized-link (sanitize-link link)))
 199              (handler-case
 200                  (merge-uris
 201                   sanitized-link
 202                   (site-link-base *current-site*))
 203                (error () sanitized-link))))))