Don’t assume resources are acct URIs
This commit is contained in:
parent
5a2562fd07
commit
fec297861b
|
@ -20,17 +20,16 @@
|
||||||
(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))
|
||||||
|
@ -54,12 +53,11 @@ in the docstring of SERVER."
|
||||||
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))
|
||||||
|
(not (str:containsp "@" resource)))
|
||||||
|
"\"Resource not a URI\"")
|
||||||
|
('t
|
||||||
|
(or (apply #'resource-json
|
||||||
|
(filter-resource-info-rels
|
||||||
rels
|
rels
|
||||||
(apply user-info-func
|
(funcall resource-info-func resource)))
|
||||||
(resource-user-host resource))))
|
"\"Couldn't find resource\"")))
|
||||||
"\"Couldn't find user\""))
|
|
||||||
(invalid-acct-uri ()
|
|
||||||
"\"Invalid acct URI\"")
|
|
||||||
(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))))
|
||||||
|
|
Ŝarĝante…
Reference in New Issue