jadedctrl/activity-servist
jadedctrl/ activity-servist
1
0
Disbranĉigi 0
Fontkodo Issues Tirpetoj Activity

Formatting tweaks (No functional change)

This commit is contained in:
Jaidyn Ann 2024-06-10 18:22:43 -05:00
parent 566b5e696c
commit 94ff3fa326
2 changed files with 49 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
src/activitypub-servist.lisp
View File

@ -1,17 +1,19 @@
;;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at> ;;;; activitypub-servist: An ActivityPub server framework.
;;;
;;; This program is free software: you can redistribute it and/or ;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at>
;;; modify it under the terms of the GNU Affero General Public License ;;
;;; as published by the Free Software Foundation, either version 3 of ;; This program is free software: you can redistribute it and/or
;;; the License, or (at your option) any later version. ;; modify it under the terms of the GNU Affero General Public License
;;; ;; as published by the Free Software Foundation, either version 3 of
;;; This program is distributed in the hope that it will be useful, ;; the License, or (at your option) any later version.
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; This program is distributed in the hope that it will be useful,
;;; GNU Affero General Public License for more details. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; You should have received a copy of the GNU Affero General Public License ;; GNU Affero General Public License for more details.
;;; along with this program. If not, see <https://www.gnu.org/licenses/>. ;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(defpackage #:activitypub-servist (defpackage #:activitypub-servist
(:use #:cl #:activitypub-servist/signatures) (:use #:cl #:activitypub-servist/signatures)
@ -24,13 +26,11 @@
"List of the server's usernames." "List of the server's usernames."
'("servistchjo")) '("servistchjo"))
(defun userhosts () (defun userhosts ()
"List of the server's usernames + hostname." "List of the server's usernames + hostname."
(mapcar (lambda (username) (str:concat username "@" "etc.xwx.moe")) (mapcar (lambda (username) (str:concat username "@" "etc.xwx.moe"))
(users))) (users)))
(defun directories () (defun directories ()
"Alist of the server's paths and their response functions." "Alist of the server's paths and their response functions."
'(("u/" . http-user-dir) '(("u/" . http-user-dir)
@ -43,9 +43,8 @@
;; ———————————————————————————————————————— ;;; Host-info response
;; Host-info response ;;; ————————————————————————————————————————
;; ————————————————————————————————————————
(defun http-host-meta (&optional env path-items params) (defun http-host-meta (&optional env path-items params)
`(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\"?>
@ -58,13 +57,11 @@
;; ———————————————————————————————————————— ;;; 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) (resource-info-func resource)) nil))
(defun resource-userhost (resource) (defun resource-userhost (resource)
"Given an account URI in webfinger-friendly format, return the corresponding))) "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 username and host in a list. Whether or not these are valid… that’s your
@ -88,7 +85,6 @@ Ex: acct:mom@bird.com → '(“mom” “bird.com”)"
(pathname-name resource) (pathname-name resource)
(purl:url-host resource))))) (purl:url-host resource)))))
(defun resource-valid-p (resource) (defun resource-valid-p (resource)
"Given a webfinger-style “resource”" "Given a webfinger-style “resource”"
(let* ((userhost (resource-userhost resource)) (let* ((userhost (resource-userhost resource))
@ -98,7 +94,6 @@ Ex: acct:mom@bird.com → '(“mom” “bird.com”)"
(string-equal (string-downcase a) (string-equal (string-downcase a)
(string-downcase b)))))) (string-downcase b))))))
(defun resource-info-func (resource) (defun resource-info-func (resource)
"Given a webfinger RESOURCE, return a property-list of data on the given user… "Given a webfinger RESOURCE, return a property-list of data on the given user…
if they exist, that is. if they exist, that is.
@ -121,20 +116,17 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
rel "http://ostatus.org/schema/1.0/subscribe")))))) rel "http://ostatus.org/schema/1.0/subscribe"))))))
;; ———————————————————————————————————————— ;;; User info response(s)
;; User info response(s) ;;; ————————————————————————————————————————
;; ————————————————————————————————————————
;; Respond to requests within the /u/* directory.
(defun http-user-dir (env path-items params) (defun http-user-dir (env path-items params)
"Respond to requests within the /u/* directory."
(let ((user (car path-items))) (let ((user (car path-items)))
;; In case of request for the user's actor. ;; In case of request for the user's actor.
(if (member user (users) :test 'equal) (if (member user (users) :test 'equal)
`(200 (:content-type "application/activity+json") `(200 (:content-type "application/activity+json")
(,(user-actor env user)))))) (,(user-actor env user))))))
(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 (str:concat "https://" (getf config :domain) "/u/" username))
@ -175,9 +167,8 @@ Mi ne estas knabino!!")
;; ———————————————————————————————————————— ;;; Sending a note
;; Sending a note ;;; ————————————————————————————————————————
;; ————————————————————————————————————————
(defun note-json (from to text) (defun note-json (from to text)
"The JSON of a user's actor." "The JSON of a user's actor."
(let* ((user-root from) (let* ((user-root from)
@ -198,12 +189,10 @@ Mi ne estas knabino!!")
"content" text "content" text
"to" (if (listp to) to (list to)))))))))) "to" (if (listp to) to (list to))))))))))
(defvar +date-header-datetime-format+ (defvar +date-header-datetime-format+
'(:short-weekday ", " (:day 2) " " :short-month " " (:year 4) " " '(:short-weekday ", " (:day 2) " " :short-month " " (:year 4) " "
(:hour 2) #\: (:min 2) #\: (:sec 2) " " :timezone)) (:hour 2) #\: (:min 2) #\: (:sec 2) " " :timezone))
(defun note-headers (inbox from to json) (defun note-headers (inbox from to json)
(let* ((inbox-uri (quri:uri inbox)) (let* ((inbox-uri (quri:uri inbox))
(digest-header (str:concat "SHA-256=" (string-sha256sum json))) (digest-header (str:concat "SHA-256=" (string-sha256sum json)))
@ -236,7 +225,6 @@ Mi ne estas knabino!!")
("Accept" . "application/activity+json") ("Accept" . "application/activity+json")
("Content-Type" . "application/activity+json")))) ("Content-Type" . "application/activity+json"))))
(defun send-note (inbox from to text) (defun send-note (inbox from to text)
(let* ((json (note-json from to text)) (let* ((json (note-json from to text))
(headers (note-headers inbox from to json))) (headers (note-headers inbox from to json)))
@ -244,11 +232,9 @@ Mi ne estas knabino!!")
:headers headers))) :headers headers)))
;; ———————————————————————————————————————— ;;; Misc. responses
;; Misc. responses ;;; ————————————————————————————————————————
;; ————————————————————————————————————————
(defun http-404 (env path-items params) (defun http-404 (env path-items params)
"The default 404 response." "The default 404 response."
'(404 (:content-type "text/plain") '(404 (:content-type "text/plain")
@ -256,9 +242,10 @@ Mi ne estas knabino!!")
(defvar *logs* '()) (defvar *logs* '())
;; ————————————————————————————————————————
;; 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 data `env`."
(setq *logs* (append *logs* (list env (babel:octets-to-string (alexandria:read-stream-content-into-byte-vector (getf env :raw-body)))))) (setq *logs* (append *logs* (list env (babel:octets-to-string (alexandria:read-stream-content-into-byte-vector (getf env :raw-body))))))
@ -275,7 +262,6 @@ 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 (&optional (config '(:domain "localhost" :port 8080)))
"Start the server." "Start the server."
(clack:clackup (lambda (env) (clack:clackup (lambda (env)
@ -286,9 +272,8 @@ Mi ne estas knabino!!")
;; ———————————————————————————————————————— ;;; Utils.
;; Utils. ;;; ————————————————————————————————————————
;; ————————————————————————————————————————
(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 "Given an associative list and a path decomposed into a list of
its components, return the item with the closest according its components, return the item with the closest according
@ -308,13 +293,11 @@ or “/bear/apple/” or “/bear/”, but not “/bear” (not a directory)."
(cdr (reverse path-items))) (cdr (reverse path-items)))
(+ depth 1)))))) (+ depth 1))))))
(defun pathname-sans-parameters (path) (defun pathname-sans-parameters (path)
"Removes parameters from a URI pathname, returning the bare path. "Removes parameters from a URI pathname, returning the bare path.
“/path/a/b?a=1&b=3” → “/path/a/b”" “/path/a/b?a=1&b=3” → “/path/a/b”"
(car (str:split #\? path))) (car (str:split #\? path)))
(defun pathname-parameters (path) (defun pathname-parameters (path)
"Convert the parameters of a URI pathname into an associative list. "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”))" “/path/a/b?a=1&b=2&c=3” → ((“a” . “1”) (“b” . “2”) (“c” . “3”))"
@ -325,14 +308,11 @@ or “/bear/apple/” or “/bear/”, but not “/bear” (not a directory)."
(cadr pair-items)))) (cadr pair-items))))
(str:split #\& (cadr (str:split #\? path))))) (str:split #\& (cadr (str:split #\? path)))))
(defun pathname-components (pathname) (defun pathname-components (pathname)
"Split a pathname into a list of its components. "Split a pathname into a list of its components.
“/u/bear/apple.txt” → '(“u” “bear” “apple.txt”)" “/u/bear/apple.txt” → '(“u” “bear” “apple.txt”)"
(str:split #\/ pathname :omit-nulls 't)) (str:split #\/ pathname :omit-nulls 't))
(defun sequence-hexadecimal-string (sequence) (defun sequence-hexadecimal-string (sequence)
(reduce #'str:concat (reduce #'str:concat
(loop for number across (loop for number across

30
src/signatures.lisp
View File

@ -1,17 +1,19 @@
;;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at> ;;;; activitypub-servist/signatures: Handle AP-compatible HTTP signatures.
;;;
;;; This program is free software: you can redistribute it and/or ;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at>
;;; modify it under the terms of the GNU Affero General Public License ;;
;;; as published by the Free Software Foundation, either version 3 of ;; This program is free software: you can redistribute it and/or
;;; the License, or (at your option) any later version. ;; modify it under the terms of the GNU Affero General Public License
;;; ;; as published by the Free Software Foundation, either version 3 of
;;; This program is distributed in the hope that it will be useful, ;; the License, or (at your option) any later version.
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; This program is distributed in the hope that it will be useful,
;;; GNU Affero General Public License for more details. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; You should have received a copy of the GNU Affero General Public License ;; GNU Affero General Public License for more details.
;;; along with this program. If not, see <https://www.gnu.org/licenses/>. ;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(defpackage #:activitypub-servist/signatures (defpackage #:activitypub-servist/signatures
(:use #:cl) (:use #:cl)