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/|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 "<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))))
 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))))))