Use Webtentacle for webfinger requests
This commit is contained in:
parent
b5961be00c
commit
906d2b0624
|
@ -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… that’s 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))
|
||||
|
||||
|
|
Ŝarĝante…
Reference in New Issue