Use Webtentacle for webfinger requests

This commit is contained in:
Jaidyn Ann 2023-08-31 17:59:15 -05:00
parent b5961be00c
commit 906d2b0624

View File

@ -15,17 +15,68 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;
(ql:quickload '(alexandria clack str yason))
(ql:quickload '(alexandria asn1 clack cl-base64 ironclad purl str trivia trivial-utf-8 webtentacle yason))
;; List of the server's usernames.
(defun users () '("rod" "mum"))
(defun users () '("rod@localhost" "mum@localhost"))
;; Alist of the server's paths and their response functions.
(defun directories () '(("u/" . http-user-dir)
(".well-known/webfinger" . http-webfinger)))
(defun directories () '(("u/" . http-dir) (".well-known/webfinger" . http-webfinger)))
;; (defparameter *s* (start-server '(:domain "etc.xwx.moe")))
(defun resource-userhost (resource)
"Given an account URI in webfinger-friendly format, return the corresponding)))
username and host in a list. Whether or not these are valid thats your
business!
Ex: acct:mom@bird.com '(mom bird.com)"
(cond
;; A @bird@mom-style resource
((str:containsp "@" resource)
(let* ((sans-acct (if (str:starts-with-p "acct:" resource)
(subseq resource 5)
resource))
(sans-@ (if (str:starts-with-p "@" sans-acct)
(subseq sans-acct 1)
sans-acct)))
(destructuring-bind (user host)
(str:split "@" sans-@)
(cons user host))))
;; A URL-style resource
((str:containsp "/u/" resource)
(cons
(pathname-name resource)
(purl:url-host resource)))))
(defun resource-valid-p (resource)
"Given a webfinger-style “resource”"
(let* ((userhost (resource-userhost resource))
(userhost-str (funcall #'str:concat (car userhost) "@" (cdr userhost))))
(member userhost-str (users)
:test (lambda (a b)
(string-equal (string-downcase a)
(string-downcase b))))))
(defun resource-info-func (resource)
"Given a webfinger RESOURCE, return a property-list of data on the given user
if they exist, that is.
This is used by the WEBTENTACLE webfinger server; you can see information on
the plist in the docstring for its WEBTENTACLE:SERVER function."
(let* ((userhost (resource-userhost resource))
(profile (str:concat "https://" (cdr userhost) "/users/" resource)))
(when (resource-valid-p resource)
(list
:subject resource
:links
`((href ,profile
rel "http://webfinger.net/rel/profile-page"
type "text/html"
properties (:apple 3 :bear 4))
(href ,profile
rel "self"
type "application/activity+json"))))))
;; The default 404 response.
@ -43,17 +94,8 @@
(,(user-actor env user))))))
;; Respond to /.well-known/webfinger?resource=acct:* requests.
(defun http-webfinger (env path-items params)
(let* ((resource (cdr (assoc "resource" params :test 'string=)))
(userhost (str:split #\@ (str:replace-all "acct:" "" resource))))
(if (and userhost
(string= (cadr userhost) (getf env :domain))
(member (car userhost) (users) :test 'string=))
`(200 (:content-type "application/json")
(,(user-webfinger env (car userhost))))
'(404 (:content-type "application/json")
("Couldn't find user")))))
(webtentacle:server env (lambda (resource) (resource-info-func resource)) nil))
;; Returns the response data for Clack, given the request data `env`.
@ -74,13 +116,13 @@
;; Start the server.
(defun start-server (&optional (config '(:domain "localhost")))
(clack:clackup (lambda (env)
(funcall 'server
(append env config)))
(server (append env config)))
:server 'woo
:address "0.0.0.0"
:port 8080))
;; The JSON of a user's actor.
(defun user-actor (config username)
(let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username)))
@ -95,26 +137,6 @@
("outbox" . ,(str:concat user-root "/outbox.json")))))))
;; Webfinger JSON — for requesting data on actors' addresses, etc.
(defun user-webfinger (config username)
(yason:with-output-to-string* ()
(yason:encode
(alexandria:alist-hash-table
`(("subject"
. ,(str:concat "acct:" username "@" (getf config :domain)))
("links"
,(alexandria:alist-hash-table
`(("rel" . "self")
("type" . "application/activity+json")
("href"
. ,(str:concat "https://" (getf config :domain)
"/u/" username))))
,(alexandria:alist-hash-table
`(("rel" . "http://ostatus.org/schema/1.0/subscribe")
("template"
. ,(str:concat "https://" (getf config :domain)
"/ostatus/subscribe?acct={uri}"))))))))))
;; Given an associative list and a path decomposed into a list of
;; its components, return the item with the closest according
@ -157,4 +179,3 @@
;; "/u/bear/apple.txt" → '("u" "bear" "apple.txt")
(defun pathname-components (pathname)
(str:split #\/ pathname :omit-nulls 't))