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
10 #:convert-any-link
* #:convert-any-link
#:presentable-link
)
11 (:unintern
#:generate-post-link
#:convert-lw2-user-link
))
13 (in-package #:lw2.links
)
15 (defun sanitize-link (link)
16 (substitute #\
+ #\Space
(string-trim " " link
)))
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
)
27 (defmacro match-values
(regex input registers
)
28 (with-gensyms (match? strings
)
29 (labels ((register-body (x)
31 (integer `(elt ,strings
,x
))
33 (t (cons (register-body (car x
)) (register-body (cdr x
)))))))
34 `(multiple-value-bind (,match?
,strings
) (ppcre:scan-to-strings
,regex
,input
)
36 (values ,.
(register-body registers
)))))))
38 (defmethod link-for-site-p ((s site
) link
) nil
)
40 (defmethod link-for-site-p ((s lesswrong-viewer-site
) link
)
41 (ppcre:scan
"^https?://(?:www\\.)?(?:less(?:er|est)?wrong\\.com|alignmentforum\\.org)" link
))
43 (defmethod link-for-site-p ((s ea-forum-viewer-site
) link
)
44 (ppcre:scan
"^https?://(?:www\\.)?(?:effective-altruism\\.com|forum\\.effectivealtruism\\.org)" link
))
46 (defmethod link-for-site-p ((s arbital-site
) link
)
47 (ppcre:scan
"^https?://(?:www\\.)?(?:arbital\\.com)" link
))
49 (defun find-link-site (link)
50 (if (ppcre:scan
"^/(?!/)" link
)
52 (loop for s in
*sites
*
53 when
(link-for-site-p s link
) return s
)))
55 (defun site-link-prefix (site)
56 (if (eq site
*current-site
*)
60 (defun match-lw1-link (link) (match-values "(?:^https?://(?:www.)?less(?:er|est)?wrong.com|^)(?:/r/discussion|/r/lesswrong|/r/all)?(/lw/.*)" link
(0)))
62 (defun match-ea1-link (link) (match-values "^(?:https?://(?:www\\.)?(?:effective-altruism\\.com|forum\\.effectivealtruism\\.org))?(/ea/.*)" link
(0)))
64 (defun match-agentfoundations-link (link) (match-values "^(?:https?://(?:www\\.)?agentfoundations\\.org)?(/item\\?id=.*)" link
(0)))
66 (defun match-lw2-link (link) (match-values "^(?:https?://[^/]+)?/(post|event)s/([^/]+)(?:/([^/#?]*)(?:/(comment|answer)/([^/#?]+)|/?(?:#(?:comment-)?|\\?commentId=)([^/#]+))?)?" link
(1 (or 4 5) 2 3 0)))
68 (defun match-lw2-slug-link (link) (match-values "^(?:https?://(?:www.)?less(?:er|est)?wrong.com)?/(?:codex|hpmor)/([^/#]+)(?:/?#?([^/#]+)?)?" link
(0 1)))
70 (defun match-lw2-sequence-link (link) (match-values "^(?:https?://[^/]+)?/s/([^/#]+)(?:/p/([^/#]+))?(?:#([^/#]+)?)?" link
(0 1 2)))
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
)))
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
)))
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
))))
87 (defun direct-link (&optional c
)
89 (if-let (restart (find-restart 'direct-link
))
90 (invoke-restart restart
)))
92 (defmacro with-direct-link
(&body body
)
94 ((serious-condition #'direct-link
))
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
))))
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
))))))
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"))
111 (defun convert-lw1-link (link)
112 (convert-redirect-link link
#'match-lw1-link
#'get-lw1-link
"https://www.lesswrong.com"))
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"))
117 (defun convert-ea1-link (link)
118 (convert-redirect-link link
#'match-ea1-link
#'get-ea1-link
"https://forum.effectivealtruism.org"))
120 (defun match-overcomingbias-link (link)
121 (if (ppcre:scan
"^https?://(?:www\\.)?overcomingbias\\.com/" link
)
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
)
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
"")
136 (convert-lw1-link lw1-link
))))))
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"))
141 (defun convert-agentfoundations-link (link)
142 (convert-redirect-link link
#'match-agentfoundations-link
#'get-agentfoundations-link
"https://www.lesswrong.com"))
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
))
147 (defun convert-lw2-slug-link (link)
148 (multiple-value-bind (slug comment-id
) (match-lw2-slug-link link
)
150 (gen-internal (get-slug-postid slug
) slug comment-id
))))
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
)
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
))))))
159 (defun convert-lw2-link (link)
160 (multiple-value-bind (post-id comment-id slug
) (match-lw2-link link
)
162 (if-let (site (find-link-site link
))
163 (gen-internal post-id slug comment-id
(site-link-prefix site
))))))
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
)))
169 (typecase item-designator
171 (gen-internal item-designator
(get-post-slug item-designator
) comment-id absolute stream
(or item-subtype
"post")))
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"))))))
176 (with-output-to-designator (out stream
)
177 (format out
"~Atag/~A~@[#comment-~A~]" (or absolute
"/") item-designator comment-id
))))))
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
))))
191 (defun convert-any-link (url)
192 (or (convert-any-link* url
) url
))
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
)))
202 (site-link-base *current-site
*))
203 (error () sanitized-link
))))))