Formatting tweaks (No functional change)
This commit is contained in:
parent
566b5e696c
commit
94ff3fa326
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Ŝarĝante…
Reference in New Issue