Reformatting & system definition; no func. change

This commit is contained in:
Jaidyn Ann 2023-09-01 22:20:13 -05:00
parent 906d2b0624
commit f2366f7858
2 changed files with 74 additions and 43 deletions

3
activitypub-servist.asd Normal file
View File

@ -0,0 +1,3 @@
(defsystem "activitypub-servist"
:depends-on ("alexandria" "clack" "purl" "str" "webtentacle" "yason")
:components ((:file "activitypub-servist")))

View File

@ -15,14 +15,32 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>. ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;; ;;
(ql:quickload '(alexandria asn1 clack cl-base64 ironclad purl str trivia trivial-utf-8 webtentacle yason))
(defpackage #:activitypub-servist
(:use #:cl)
(:export :server :start-server))
(in-package #:activitypub-servist)
;;(ql:quickload '(alexandria asn1 clack cl-base64 ironclad purl str trivia trivial-utf-8 webtentacle yason))
;; List of the server's usernames. (defun users ()
(defun users () '("rod@localhost" "mum@localhost")) "List of the server's usernames."
'("rod@localhost" "mum@localhost"))
;; Alist of the server's paths and their response functions.
(defun directories () '(("u/" . http-dir) (".well-known/webfinger" . http-webfinger))) (defun directories ()
"Alist of the server's paths and their response functions."
'(("u/" . http-dir) (".well-known/webfinger" . http-webfinger)))
;; ————————————————————————————————————————
;; Webfinger response
;; ————————————————————————————————————————
(defun http-webfinger (env path-items params)
(webtentacle:server env (lambda (resource) (resource-info-func resource)) nil))
(defun resource-userhost (resource) (defun resource-userhost (resource)
@ -79,12 +97,10 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
type "application/activity+json")))))) type "application/activity+json"))))))
;; The default 404 response.
(defun http-404 (env path-items params) ;; ————————————————————————————————————————
'(404 (:content-type "text/plain") ;; User info response(s)
("404, you goddamn fool!"))) ;; ————————————————————————————————————————
;; Respond to requests within the /u/* directory. ;; Respond to requests within the /u/* directory.
(defun http-user-dir (env path-items params) (defun http-user-dir (env path-items params)
(let ((user (car path-items))) (let ((user (car path-items)))
@ -94,12 +110,36 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
(,(user-actor env user)))))) (,(user-actor env user))))))
(defun http-webfinger (env path-items params) (defun user-actor (config username)
(webtentacle:server env (lambda (resource) (resource-info-func resource)) nil)) "The JSON of a user's actor."
(let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username)))
(yason:with-output-to-string* ()
(yason:encode-alist
`(("@context" . ("https://www.w3.org/ns/activitystreams"
"https://w3id.org/security/v1"))
("id" . ,user-root)
("type" . "Person")
("preferredUsername" . ,username)
("inbox" . ,(str:concat user-root "/inbox.json"))
("outbox" . ,(str:concat user-root "/outbox.json")))))))
;; Returns the response data for Clack, given the request data `env`.
;; ————————————————————————————————————————
;; Misc. responses
;; ————————————————————————————————————————
(defun http-404 (env path-items params)
"The default 404 response."
'(404 (:content-type "text/plain")
("404, you goddamn fool!")))
;; ————————————————————————————————————————
;; Invocation
;; ————————————————————————————————————————
(defun server (env) (defun server (env)
"Returns the response data for Clack, given the request data `env`."
(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
@ -113,8 +153,8 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
(funcall 'http-404 env path-sans-response-root params)))) (funcall 'http-404 env path-sans-response-root params))))
;; Start the server.
(defun start-server (&optional (config '(:domain "localhost"))) (defun start-server (&optional (config '(:domain "localhost")))
"Start the server."
(clack:clackup (lambda (env) (clack:clackup (lambda (env)
(server (append env config))) (server (append env config)))
:server 'woo :server 'woo
@ -122,29 +162,17 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
:port 8080)) :port 8080))
;; The JSON of a user's actor. ;; ————————————————————————————————————————
(defun user-actor (config username) ;; Utils.
(let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username))) ;; ————————————————————————————————————————
(yason:with-output-to-string* ()
(yason:encode-alist
`(("@context" . ("https://www.w3.org/ns/activitystreams"
"https://w3id.org/security/v1"))
("id" . ,user-root)
("type" . "Person")
("preferredUsername" . ,username)
("inbox" . ,(str:concat user-root "/inbox.json"))
("outbox" . ,(str:concat user-root "/outbox.json")))))))
;; Given an associative list and a path decomposed into a list of
;; its components, return the item with the closest according
;; pathname as key. If the exact path isn't a valid key, it will
;; try all parent directories.
;; E.g., "/bear/apple/momma/" could match either "/bear/apple/momma"
;; or "/bear/apple/" or "/bear/", but not "/bear" (not a directory).
(defun assoc-by-path (alist path-items &optional (depth 0)) (defun assoc-by-path (alist path-items &optional (depth 0))
"Given an associative list and a path decomposed into a list of
its components, return the item with the closest according
pathname as key. If the exact path isn't a valid key, it will
try all parent directories.
E.g., /bear/apple/momma/ could match either /bear/apple/momma
or /bear/apple/ or /bear/, but not /bear (not a directory)."
(let ((path (str:join #\/ path-items))) (let ((path (str:join #\/ path-items)))
(if (eq path-items nil) (if (eq path-items nil)
(assoc "" alist :test 'string=) (assoc "" alist :test 'string=)
@ -158,15 +186,15 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
(+ depth 1)))))) (+ depth 1))))))
;; Removes parameters from a URI pathname, returning the bare path.
;; "/path/a/b?a=1&b=3" → "/path/a/b"
(defun pathname-sans-parameters (path) (defun pathname-sans-parameters (path)
"Removes parameters from a URI pathname, returning the bare path.
/path/a/b?a=1&b=3 /path/a/b"
(car (str:split #\? path))) (car (str:split #\? path)))
;; Convert the parameters of a URI pathname into an associative list.
;; "/path/a/b?a=1&b=2&c=3" → (("a" . "1") ("b" . "2") ("c" . "3"))
(defun pathname-parameters (path) (defun pathname-parameters (path)
"Convert the parameters of a URI pathname into an associative list.
/path/a/b?a=1&b=2&c=3 ((a . 1) (b . 2) (c . 3))"
(mapcar (mapcar
(lambda (pair) (lambda (pair)
(let ((pair-items (str:split #\= pair))) (let ((pair-items (str:split #\= pair)))
@ -175,7 +203,7 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
(str:split #\& (cadr (str:split #\? path))))) (str:split #\& (cadr (str:split #\? path)))))
;; Split a pathname into a list of its components.
;; "/u/bear/apple.txt" → '("u" "bear" "apple.txt")
(defun pathname-components (pathname) (defun pathname-components (pathname)
"Split a pathname into a list of its components.
/u/bear/apple.txt '(u bear apple.txt)"
(str:split #\/ pathname :omit-nulls 't)) (str:split #\/ pathname :omit-nulls 't))