jadedctrl/webtentacle
jadedctrl/ webtentacle
1
0
Disbranĉigi 0
Fontkodo Issues Tirpetoj Activity

Don’t assume resources are acct URIs

This commit is contained in:
Jaidyn Ann 2023-07-28 07:19:22 -05:00
parent 5a2562fd07
commit fec297861b
1 changed files with 59 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
webtentacle.lisp
View File

@ -20,46 +20,44 @@
(in-package #:webtentacle) (in-package #:webtentacle)
(defun user-json (&key user host aliases properties links) (defun resource-json (&key subject aliases properties links)
"Given the USER’s information, return the applicable Webfinger JSON. "Given the RESOURCE’s information, return the applicable Webfinger JSON.
Details of the values of USER, HOST, ALIASES, PROPERTIES, and LINKS can be found Details of the values of RESOURCE, ALIASES, PROPERTIES, and LINKS can be found
in the docstring of SERVER." in the docstring of SERVER."
(let ((yason:*symbol-key-encoder* #'yason:encode-symbol-as-lowercase) (let ((yason:*symbol-key-encoder* #'yason:encode-symbol-as-lowercase)
(yason:*symbol-encoder* #'yason:encode-symbol-as-lowercase)) (yason:*symbol-encoder* #'yason:encode-symbol-as-lowercase))
(yason:with-output-to-string* () (yason:with-output-to-string* ()
(yason:with-object () (yason:with-object ()
(yason:encode-object-element (when subject
"subject" (yason:encode-object-element "subject" subject))
(concatenate 'string "acct:" user "@" host)) (when (and aliases (listp aliases))
(when (and aliases (listp aliases)) (yason:encode-object-element "aliases" aliases))
(yason:encode-object-element "aliases" aliases)) (when (and properties (listp properties))
(when (and properties (listp properties)) (yason:encode-object-element
(yason:encode-object-element "properties"
"properties" (alexandria:plist-hash-table properties)))
(alexandria:plist-hash-table properties))) (when (and links (listp links))
(when (and links (listp links)) (yason:encode-object-element
(yason:encode-object-element "links"
"links" ;; Each link needs to be a hash-table (so it's encoded as a JSON object.
;; Each link needs to be a hash-table (so it's encoded as a JSON object. (mapcar
(mapcar (lambda (link)
(lambda (link) ;; Each link’s properties/titles need to be hash-tables, likewise.
;; Each link’s properties/titles need to be hash-tables, likewise. (let ((properties (getf link 'properties))
(let ((properties (getf link 'properties)) (titles (getf link 'titles)))
(titles (getf link 'titles))) (when (and properties (not (hash-table-p properties)))
(when (and properties (not (hash-table-p properties))) (setf (getf link 'properties) (alexandria:plist-hash-table properties)))
(setf (getf link 'properties) (alexandria:plist-hash-table properties))) (when (and titles (not (hash-table-p titles)))
(when (and titles (not (hash-table-p titles))) (setf (getf link 'titles) (alexandria:plist-hash-table titles))))
(setf (getf link 'titles) (alexandria:plist-hash-table titles)))) (alexandria:plist-hash-table link))
(alexandria:plist-hash-table link)) links)))))))
links)))))))
(defun fake-info-func (user host) (defun fake-info-func (resource)
"A testing function. This is a USER-INFO-FUNC function that outputs garbage." "A testing function. This is a RESOURCE-INFO-FUNC function that outputs garbage."
(let ((profile (str:concat "https://example.example/users/" user))) (let ((profile (str:concat "https://example.example/users/" resource)))
(list (list
:user user :subject resource
:host host
:aliases (list profile "https://example.example/users/old-user") :aliases (list profile "https://example.example/users/old-user")
:links :links
`((href ,profile `((href ,profile
@ -71,23 +69,6 @@ in the docstring of SERVER."
type "application/activity+json"))))) type "application/activity+json")))))
(define-condition invalid-acct-uri (error) ()
(:documentation "Thrown when a user@host acct URI is expected, but is lacking a user or host potion."))
(defun resource-user-host (resource)
"Given a queried RESOURCE, return a list of its contained user and host."
(let* ((sans-acct (if (str:starts-with-p "acct:" resource)
(subseq resource 5)
resource))
(user-host (str:split #\@ sans-acct)))
(if (or (not (eq (length user-host) 2))
(str:emptyp (car user-host))
(str:emptyp (cadr user-host)))
(error 'invalid-acct-uri :message "Invalid acct resource")
user-host)))
(defun filter-link-rels (rels link-plists) (defun filter-link-rels (rels link-plists)
"Given a list of link property-lists, filter out links whose rel properties "Given a list of link property-lists, filter out links whose rel properties
aren’t a member of the RELS list. aren’t a member of the RELS list.
@ -102,18 +83,18 @@ in RELS will remain."
link-plists)) link-plists))
(defun filter-user-info-rels (rels user-info) (defun filter-resource-info-rels (rels resource-info)
"Filter the :LINKS property-list’s properties from a USER-INFO property-list, "Filter the :LINKS property-list’s properties from a RESOURCE-INFO property-list,
by their relations. by their relations.
If RELS is nil, nothing is filtered out. If RELS is nil, nothing is filtered out.
If RELS is a list of strings, only links with rel properties matching a member If RELS is a list of strings, only links with rel properties matching a member
in RELS will remain." in RELS will remain."
(setf (getf user-info :links) (filter-link-rels rels (getf user-info :links))) (setf (getf resource-info :links) (filter-link-rels rels (getf resource-info :links)))
user-info) resource-info)
(defun clack-response (user-info-func resource &rest rels) (defun clack-response (resource-info-func resource &rest rels)
"Given a USER-INFO-FUNC (as per the specification of SERVER’s docstring), and "Given a RESOURCE-INFO-FUNC (as per the specification of SERVER’s docstring), and
the RESOURCE and RELS parameters from a Webfinger HTTP request, return the the RESOURCE and RELS parameters from a Webfinger HTTP request, return the
response JSON in Clack’s format. response JSON in Clack’s format.
This can be used if you don’t want to wrap your server with SERVER, and would This can be used if you don’t want to wrap your server with SERVER, and would
@ -125,34 +106,35 @@ rather handle the Webfinger path yourself."
(format (format
nil "~A" nil "~A"
(handler-case (handler-case
(if (not resource) (cond ((or (not resource) (str:emptyp resource))
"\"No resource specified\"" "\"No resource specified\"")
(or (apply #'user-json ;; If not a URI (or even an acct URI without the “acct:”)
(filter-user-info-rels ((and (not (str:containsp ":" resource))
rels (not (str:containsp "@" resource)))
(apply user-info-func "\"Resource not a URI\"")
(resource-user-host resource)))) ('t
"\"Couldn't find user\"")) (or (apply #'resource-json
(invalid-acct-uri () (filter-resource-info-rels
"\"Invalid acct URI\"") rels
(funcall resource-info-func resource)))
"\"Couldn't find resource\"")))
(error (any-error) (error (any-error)
(format nil "\"Server error: ~A\"" any-error))))))) (format nil "\"Server error: ~A\"" any-error)))))))
(defun server (env user-info-func &optional (clack-app nil)) (defun server (env resource-info-func &optional (clack-app nil))
"Start handling Webfinger requests, wrapping around the given CLACK-APP body "Start handling Webfinger requests, wrapping around the given CLACK-APP body
function. function.
USER-INFO-FUNC should be a function that will return user information to be RESOURCE-INFO-FUNC should be a function that will return resource information to
served by Webfinger. be served by Webfinger.
USER-INFO-FUNC should take two parameters: Username and host, both strings. RESOURCE-INFO-FUNC should take one parameter, the resource string.
It should return a property-list with some of the following properties: It should return a property-list with some of the following properties:
* :USER * :SUBJECT
* :HOST
* :ALIASES * :ALIASES
* :PROPERTIES * :PROPERTIES
* :LINKS * :LINKS
You need at minimum :USER and :HOST, all else is optional. You need at minimum :SUBJECT, all else is optional.
:ALIASES is a simple list of URLs. :ALIASES is a simple list of URLs.
:PROPERTIES is a simple property-list of whatever you want. :PROPERTIES is a simple property-list of whatever you want.
@ -177,7 +159,7 @@ value being the corresponding title; for example,
(if (string= (quri:uri-path uri) "/.well-known/webfinger") (if (string= (quri:uri-path uri) "/.well-known/webfinger")
;; We only want to handle the *exact* webfinger path ;; We only want to handle the *exact* webfinger path
(apply #'clack-response (apply #'clack-response
(append (list user-info-func (append (list resource-info-func
(cdr (assoc "resource" params :test #'string=))) (cdr (assoc "resource" params :test #'string=)))
;; We want all “rel” parameters, not just the first one ;; We want all “rel” parameters, not just the first one
(mapcar (mapcar
@ -191,11 +173,11 @@ value being the corresponding title; for example,
'(512 (:content-type "text/plain") ("HECK")))))) '(512 (:content-type "text/plain") ("HECK"))))))
(defun start-server (user-info-func) (defun start-server (resource-info-func)
"Run a Webfinger HTTP server, given a USER-INFO-FUNC (see SERVER’s docstring). "Run a Webfinger HTTP server, given a RESOURCE-INFO-FUNC (see SERVER’s docstring).
This is useful if you want to delegate Webfinger-handling to this library with a This is useful if you want to delegate Webfinger-handling to this library with a
reverse-proxy. reverse-proxy.
It is also useful for debugging this library." It is also useful for debugging this library."
(clack:clackup (clack:clackup
(lambda (env) (lambda (env)
(funcall #'server env user-info-func)))) (funcall #'server env resource-info-func))))