Add FETCH, and Webfinger data from JSON-objects

Now, Webfinger data is generated from JSON-LD
objects in an overridable fashion (methods).

Also defines the callback FETCH, which should be
defined by the user of activity-servist.
This commit is contained in:
Jaidyn Ann 2024-09-05 22:27:37 -05:00
parent f98b5d81a9
commit ecc8b6f46c
2 changed files with 83 additions and 67 deletions

View File

@ -9,7 +9,7 @@
:homepage "https://hak.xwx.moe/jadedctrl/activity-servist" :homepage "https://hak.xwx.moe/jadedctrl/activity-servist"
:in-order-to ((test-op (test-op "activitypub/tests"))) :in-order-to ((test-op (test-op "activitypub/tests")))
:depends-on (:activity-servist/signatures :depends-on (:activity-servist/vocab/activity :activity-servist/signatures
:alexandria :clack :dexador :alexandria :clack :dexador
:local-time :purl :str :webtentacle :yason) :local-time :purl :str :webtentacle :yason)
:components ((:file "src/activity-servist"))) :components ((:file "src/activity-servist")))

View File

@ -17,11 +17,31 @@
(defpackage #:activity-servist (defpackage #:activity-servist
(:use #:cl #:activity-servist/signatures) (:use #:cl #:activity-servist/signatures)
(:nicknames "AS") (:nicknames "AS" "ACTIVITYPUB")
(:export :server :start-server)) (:export
;; Functions
:server :start-server
;; Globals
*config*))
(in-package #:activity-servist) (in-package #:activity-servist)
;;; Globals
;;; ————————————————————————————————————————
(defvar *config* '(:address "localhost" :port 8080 :protocol "https")
"Configuration for the server, a property-list.
There are three optional properties:
:PROTOCOL, either https or http (the latter for testing, only!).
:ADDRESS, the servers domain-name/address.
:PORT, the servers port.
There is one required property:
:FETCH, a function used as a callback by activity-servist.
:FETCH should be a function of (FETCH URI)
This function should simply return an object from your storage, queried by a URI.
The URI parameter is going to be either an @ID or an account-URI of the form acct:username@hostname.")
(defun users () (defun users ()
"List of the server's usernames." "List of the server's usernames."
@ -38,9 +58,24 @@
(".well-known/webfinger" . http-webfinger) (".well-known/webfinger" . http-webfinger)
(".well-known/host-meta" . http-host-meta))) (".well-known/host-meta" . http-host-meta)))
(defvar *privkey*
(alexandria:read-file-into-string
(asdf:system-relative-pathname :activity-servist #p"enc/privkey.pem")))
(defvar *pubkey*
(alexandria:read-file-into-string
(asdf:system-relative-pathname :activity-servist #p"enc/pubkey.pem")))
(defvar *privkey* (alexandria:read-file-into-string #p"../enc/privkey.pem"))
(defvar *pubkey* (alexandria:read-file-into-string #p"../enc/pubkey.pem"))
;;; Callbacks
;;; ————————————————————————————————————————
(defun fetch (uri)
"Runs the user-defined callback FETCH, as stored in *CONFIG*.
Returns the ActivityPub object associated with the given URI."
(let ((func (getf *config* :fetch)))
(if func
(funcall func uri)
(error "No FETCH function found in ACTIVITY-SERVIST:*CONFIG*."))))
@ -50,71 +85,50 @@
`(200 (:content-type "application/xrd+xml; charset=utf-8") `(200 (:content-type "application/xrd+xml; charset=utf-8")
(,(str:concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?> (,(str:concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<XRD xmlns=\"http://docs.oasis-open.org/ns/xri/xrd-1.0\"> <XRD xmlns=\"http://docs.oasis-open.org/ns/xri/xrd-1.0\">
<link rel=\"lrdd\" type=\"application/xrd+xml\" template=\"https://" <link rel=\"lrdd\" type=\"application/xrd+xml\" template=\""
(getf env :domain) (getf *config* :protocol)
"://"
(getf *config* :address)
"/.well-known/webfinger?resource={uri}\"/> "/.well-known/webfinger?resource={uri}\"/>
</XRD> </XRD>
")))) "))))
;;; Webfinger response ;;; Webfinger response
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defun http-webfinger (env path-items params) (defun http-webfinger (env path-items params)
(webtentacle:server env (lambda (resource) (resource-info-func resource)) nil)) (webtentacle:server env (lambda (resource) (webfinger-resource-info resource))))
(defun resource-userhost (resource) (defun webfinger-resource-info (resource)
"Given an account URI in webfinger-friendly format, return the corresponding))) "Given a Webfinger RESOURCE, return a property-list of data on the given resource.
username and host in a list. Whether or not these are valid thats your Will "
business! (let ((obj (fetch resource)))
Ex: acct:mom@bird.com '(mom bird.com)" (and obj (webfinger-info resource obj))))
(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) (defgeneric webfinger-info (resource obj)
"Given a webfinger-style “resource”" (:documentation "Returns a property-list of Webfinger data on the given object.
(let* ((userhost (resource-userhost resource)) Override this to provide custom Webfinger data; do what you please, but make sure RESOURCE is set as the :SUBJECT value.
(userhost-str (funcall #'str:concat (car userhost) "@" (cdr userhost))))
(member userhost-str (userhosts)
:test (lambda (a b)
(string-equal (string-downcase a)
(string-downcase b))))))
(defun resource-info-func (resource) For information on the property-lists format, see the dosctring of WEBTENTACLE:SERVER."))
"Given a webfinger RESOURCE, return a property-list of data on the given user
if they exist, that is. ;; A default implementation, which provides (likely) all of the information
This is used by the WEBTENTACLE webfinger server; you can see information on ;; necessary for most use-cases.
the plist in the docstring for its WEBTENTACLE:SERVER function." (defmethod webfinger-info (resource (obj json-ld:object))
(let* ((userhost (resource-userhost resource)) (let ((obj-uri (json-ld:@id obj)))
(profile (str:concat "https://" (cdr userhost) "/u/" (car userhost))))
(when (resource-valid-p resource)
(list (list
:subject (str:concat "acct:" (car userhost) "@" (cdr userhost)) :subject resource
:aliases `(,profile) :aliases (list obj-uri)
:links :links
`((href ,profile ;; Note: Doesnt provide the os_status subscribe link.
`((href ,obj-uri
rel "self" rel "self"
type "application/activity+json") type "application/activity+json")
(href ,profile (href ,obj-uri
rel "self" rel "self"
type "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"") type "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"")))))
(template ,(str:concat "https://" (cdr userhost) "/ostatus_subscribe?acct={uri}")
rel "http://ostatus.org/schema/1.0/subscribe"))))))
@ -130,8 +144,10 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
(defun user-actor (config username) (defun user-actor (config username)
"The JSON of a user's actor." "The JSON of a user's actor."
(let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username)) (let* ((user-root
(yason:*symbol-encoder* 'yason:encode-symbol-as-lowercase)) (str:concat (getf *config* :protocol) "://" (getf *config* :address) "/u/" username))
(yason:*symbol-encoder*
'yason:encode-symbol-as-lowercase))
(yason:with-output-to-string* () (yason:with-output-to-string* ()
(yason:encode-alist (yason:encode-alist
`(("@context" . ("https://www.w3.org/ns/activitystreams" `(("@context" . ("https://www.w3.org/ns/activitystreams"
@ -244,8 +260,8 @@ Mi ne estas knabino!!")
;;; Invocation ;;; Invocation
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defun server (env) (defun server (env)
"Returns the response data for Clack, given the request data `env`." "Returns the response data for Clack, given the request property-list ENV."
(setq *logs* (append *logs* (list env (babel:octets-to-string (alexandria:read-stream-content-into-byte-vector (getf env :raw-body)))))) (nconc *logs* (list env (babel:octets-to-string (alexandria:read-stream-content-into-byte-vector (getf env :raw-body)))))
(let* ((path (pathname-sans-parameters (getf env :request-uri))) (let* ((path (pathname-sans-parameters (getf env :request-uri)))
(params (pathname-parameters (getf env :request-uri))) (params (pathname-parameters (getf env :request-uri)))
(response-function (response-function
@ -259,13 +275,13 @@ Mi ne estas knabino!!")
(or (funcall (cdr response-function) env path-sans-response-root params) (or (funcall (cdr response-function) env path-sans-response-root params)
(funcall 'http-404 env path-sans-response-root params)))) (funcall 'http-404 env path-sans-response-root params))))
(defun start-server (&optional (config '(:domain "localhost" :port 8080))) (defun start-server ()
"Start the server." "Start the server."
(clack:clackup (lambda (env) (clack:clackup (lambda (env)
(server (append env config))) (server env))
:server 'woo :server 'woo
:address "0.0.0.0" :address "0.0.0.0"
:port (getf config :port))) :port (getf *config* :port)))