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

Compare commits

base: jadedctrl:a604d74b5be09ade9a51d2b1764fe48189f13218
Branches Etikedoj
jadedctrl:master
..
compare: jadedctrl:6852d63a4304afcefd41980bb290d1047ea6b5bf
Branches Etikedoj
jadedctrl:master

No commits in common. "a604d74b5be09ade9a51d2b1764fe48189f13218" and "6852d63a4304afcefd41980bb290d1047ea6b5bf" have entirely different histories.
a604d74b5b ... 6852d63a43

5 changed files with 206 additions and 391 deletions
Show Stats Expand all files Collapse all files

47
activitypub-servist.asd
View File

@ -1,46 +1,5 @@
(require "asdf") (defsystem "activitypub-servist"
:depends-on ("alexandria" "clack" "dexador" "inferior-shell" "ironclad" "local-time" "purl" "str" "webtentacle" "yason")
(asdf:defsystem "activitypub-servist"
:version "0.0"
:license "AGPLv3"
:description "ActitivyPub federated server framework."
:author "Jaidyn Ann <jadedctrl@posteo.at>"
:homepage "https://hak.xwx.moe/jadedctrl/activitypub-servist"
:depends-on ("activitypub-servist/signatures"
"alexandria" "clack" "dexador"
"local-time" "purl" "str" "webtentacle" "yason")
:components ((:file "src/activitypub-servist"))) :components ((:file "src/activitypub-servist")))
;; (ql:quickload '(alexandria clack dexador inferior-shell ironclad local-time purl str webtentacle yason))
(asdf:defsystem "activitypub-servist/signatures"
:version "0.0"
:license "AGPLv3"
:description "AP-S subpackage for handling HTTP signatures."
:author "Jaidyn Ann <jadedctrl@posteo.at>"
:homepage "https://hak.xwx.moe/jadedctrl/activitypub-servist"
:depends-on ("cl-base64" "flexi-streams" "inferior-shell" "ironclad" "str")
:components ((:file "src/signatures")))
;;; Tests
;;; —————————————————————————————————————
(asdf:defsystem "activitypub-servist/tests/signatures"
:version "0.0"
:license "AGPLv3"
:author "Jaidyn Ann <jadedctrl@posteo.at>"
:description "Tests for the the activitypub-servist/signatures package."
:depends-on (:activitypub-servist/signatures :lisp-unit2)
:components ((:file "t/signatures")))
;; Following method tweaked from lisp-unit2’s documentation:
;; https://github.com/AccelerationNet/lisp-unit2/blob/master/README.md#asdf
(defmethod asdf:perform
((o asdf:test-op) (c (eql (asdf:find-system :activitypub-servist/tests/signatures))))
(eval (read-from-string
"(lisp-unit2:with-summary ()
(lisp-unit2:run-tests :package :activitypub-servist/tests/signatures))")))

118
src/activity-vocabulary.lisp
View File

@ -1,118 +0,0 @@
;;;; activity-vocabulary: Classes for ActivityVocabulary types.
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(defpackage #:activitypub-servist/activity-vocabulary
(:use #:cl)
;; One should never USE this package, since some class-names shadow
;; core Common Lisp symbols! Beware! :P
(:shadow #:delete #:ignore #:listen #:read #:remove)
(:nicknames "AP-S/AV" "AV"))
(in-package #:activitypub-servist/activity-vocabulary)
;;; Macros
;;; ————————————————————————————————————————
(defmacro defclass-w-accessors (name direct-superclasses slots &rest options)
"Identical to DEFCLASS, but with one convenience: A slot definition, if being
simply a symbol, will default to a slot with an accessor and init-arg named after the
symbol. The init-arg will be “:symbol”, and the accessor will be “classname-symbol”.
For instance,
(defclass-w-accessors PERSON () (AGE
HEIGHT
(NAME :INIT-FORM “Unknown”)))
```
is equivalent to
```
(defclass PERSON () ((AGE :INIT-ARG :AGE :ACCESSOR PERSON-AGE)
(HEIGHT :INIT-ARG :HEIGHT :ACCESSOR PERSON-HEIGHT)
(NAME :INIT-FORM “Unknown”)))
```"
`(defclass ,name ,direct-superclasses
,(mapcar
(lambda (slot)
(typecase slot
(list slot)
(t (list slot :accessor (intern (format nil "~A-~A" name slot))
:initarg (intern (symbol-name slot) "KEYWORD")))))
slots)
,@options))
(defmacro defclass-empty-children (name direct-children)
"For each name in the list DIRECT-CHILDREN, a subclass of NAME will be created.
These new subclasses have no slots of its own — they will be empty derivatives
of NAME."
(append
'(progn)
(mapcar (lambda (a)
`(defclass ,a (,name) ()))
direct-children)))
;;; Core types
;;; ————————————————————————————————————————
;; https://www.w3.org/ns/activitystreams#Object
(defclass-w-accessors object ()
(
attachment attributed-to audience bcc bto cc content context
duration end-time generator icon image in-reply-to location
media-type name preview published replies start-time summary
tag to updated url))
;; https://www.w3.org/ns/activitystreams#Link
(defclass-w-accessors link ()
(height href hreflang media-type name preview rel width))
;; https://www.w3.org/ns/activitystreams#Activity
(defclass-w-accessors activity (object)
(actor instrument object origin result target))
;; Should be ordinary Activity, sans `object`.
;; https://www.w3.org/ns/activitystreams#IntransitiveActivity
(defclass intransitive-activity (activity) ())
;; https://www.w3.org/ns/activitystreams#Collection
(defclass-w-accessors collection (object)
(current first items last total-items))
;; https://www.w3.org/ns/activitystreams#OrderedCollection
(defclass ordered-collection (collection) ())
;; https://www.w3.org/ns/activitystreams#CollectionPage
(defclass-w-accessors collection-page (collection)
(next part-of prev))
;; https://www.w3.org/ns/activitystreams#OrderedCollectionPage
(defclass-w-accessors ordered-collection-page (collection-page)
(start-index))
;;; Extended Activity types
;;; ————————————————————————————————————————
(defclass-empty-children activity
(accept add announce create delete dislike flag follow ignore join leave
like listen move offer read reject remove travel undo update view))
(defclass arrive (intransitive-activity) ())
(defclass ignore (block) ())
(defclass invite (offer) ())
(defclass question (intransitive-activity) ())
(defclass tentative-accept (accept) ())
(defclass tentative-reject (reject) ())

239
src/activitypub-servist.lisp
View File

@ -1,23 +1,20 @@
;;;; activitypub-servist: An ActivityPub server framework. ;;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at>
;;;
;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at> ;;; This program is free software: you can redistribute it and/or
;; ;;; modify it under the terms of the GNU Affero General Public License
;; This program is free software: you can redistribute it and/or ;;; as published by the Free Software Foundation, either version 3 of
;; modify it under the terms of the GNU Affero General Public License ;;; the License, or (at your option) any later version.
;; as published by the Free Software Foundation, either version 3 of ;;;
;; the License, or (at your option) any later version. ;;; This program is distributed in the hope that it will be useful,
;; ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; This program is distributed in the hope that it will be useful, ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; GNU Affero General Public License for more details.
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;
;; GNU Affero General Public License for more details. ;;; 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/>.
;; 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)
(:nicknames "AP-S")
(:export :server :start-server)) (:export :server :start-server))
(in-package #:activitypub-servist) (in-package #:activitypub-servist)
@ -27,11 +24,13 @@
"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)
@ -44,8 +43,9 @@
;;; 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,11 +58,13 @@
;;; 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
@ -86,6 +88,7 @@ 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))
@ -95,6 +98,7 @@ 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.
@ -117,17 +121,20 @@ 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))
@ -168,8 +175,9 @@ 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)
@ -190,10 +198,12 @@ 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)))
@ -209,7 +219,11 @@ Mi ne estas knabino!!")
(format nil "host: ~A~%" (quri:uri-host inbox-uri)) (format nil "host: ~A~%" (quri:uri-host inbox-uri))
(format nil "date: ~A~%" date-header) (format nil "date: ~A~%" date-header)
(format nil "digest: ~A" digest-header))) (format nil "digest: ~A" digest-header)))
(signature (sign-string *privkey* signed-headers)) (signature (base64:usb8-array-to-base64-string
(ironclad:sign-message (openssl-shell-import-key-pair *privkey*)
(string-to-ub8-vector
(string-sha256sum signed-headers)))))
(signature (openssl-shell-sign-string *privkey* signed-headers))
(signature-header (str:concat "keyId=\"" from "#main-key\"," (signature-header (str:concat "keyId=\"" from "#main-key\","
"algorithm=\"rsa-sha256\"," "algorithm=\"rsa-sha256\","
"headers=\"(request-target) host date digest\"," "headers=\"(request-target) host date digest\","
@ -222,6 +236,7 @@ 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)))
@ -229,9 +244,11 @@ 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")
@ -239,10 +256,9 @@ 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))))))
@ -259,6 +275,7 @@ 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)
@ -269,8 +286,9 @@ 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
@ -290,11 +308,13 @@ 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”))"
@ -305,13 +325,160 @@ 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 string-to-ub8-vector (string)
"Convert the given STRING into an unsigned 8-bit vector."
(coerce
(loop for char across string
collect (char-code char))
'(vector (unsigned-byte 8))))
(defun digest-string (digest-spec string)
"Compute the digest of a STRING, given an Ironclad DIGEST-SPEC."
(ironclad:digest-sequence digest-spec (string-to-ub8-vector string)))
(defun string-sha256sum (string)
"Compute the sha256 checksum of a STRING, in hexadecimal string-format."
(base64:usb8-array-to-base64-string
(digest-string (ironclad:make-digest :sha256) string)))
(defun sequence-hexadecimal-string (sequence) (defun sequence-hexadecimal-string (sequence)
(reduce #'str:concat (reduce #'str:concat
(loop for number across (loop for number across
sequence sequence
collect (format nil "~X" number)))) collect (format nil "~X" number))))
;; ————————————————————————————————————————
;; RSA keys
;; ————————————————————————————————————————
;; At the moment, I’ve yet to use figure out how to create PEM representations of
;; a public keypair properly in Lisp.
;; So at the moment, keys are generated into PEM files by the openssl binary on
;; the host’s system; and the output of the openssl command is used to parse into
;; Ironclad keys.
;; Yes, I know, this is absolutely horrific. Actually disgusting.
;; But at the moment,I want to focus on other core parts of ActivityPub; I’ve
;; tired of messing with ASN1 & co. That’s for another day! ^^
(defun openssl-shell-generate-key-pair ()
"Generate a 2048-bit RSA key-pair in PEM-format using one’s `openssl` binary.
It returns two values: The private key, then the public key."
(let* ((private-pem-key (inferior-shell:run/s "openssl genrsa 2048"))
(public-pem-key
(inferior-shell:run/s
`(inferior-shell:pipe (echo ,private-pem-key)
(openssl rsa -outform PEM -pubout)))))
(values private-pem-key
public-pem-key)))
(defun openssl-shell-destructure-private-key (pem-string &optional results)
"When passed the output of the shell command `openssl rsa -text -noout`, will
parse the output into a plist containing relavent numbers:
:n (modulus), :e (public exponent), :d (private exponent), :p (1st prime),
:q (2nd prime), :e1 (1st exponent), :e2 (2nd exponent), and :c (coefficient)."
(let* ((lines (if (stringp pem-string)
(inferior-shell:run/lines
`(inferior-shell:pipe
(echo ,pem-string)
(openssl rsa -text -noout)))
pem-string))
(line (str:trim (car lines))))
(cond
((not lines)
(mapcar
(lambda (result-item)
(if (stringp result-item)
(parse-integer (str:replace-all ":" "" result-item) :radix 16)
result-item))
results))
((str:starts-with-p "Private" line)
(openssl-shell-destructure-private-key
(cdr lines) results))
((str:starts-with-p "modulus:" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:n))))
((str:starts-with-p "prime1" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:p))))
((str:starts-with-p "prime2" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:q))))
((str:starts-with-p "exponent1" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:e1))))
((str:starts-with-p "exponent2" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:e2))))
((str:starts-with-p "coefficient" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:c))))
((str:starts-with-p "privateExponent" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:d))))
((str:starts-with-p "publicExponent" line)
(openssl-shell-destructure-private-key
(cdr lines)
(nconc
results
(list
:e
(parse-integer
(car (str:split #\space
(str:replace-first
"publicExponent: "
""
line))))))))
('t
(let* ((last-element (car (last results)))
(total-string (if (stringp last-element)
(str:concat last-element line)
line)))
(openssl-shell-destructure-private-key
(cdr lines)
(if (stringp last-element)
(nconc (reverse (cdr (reverse results)))
(list total-string))
(nconc results
(list total-string)))))))))
(defun openssl-shell-import-key-pair (private-pem-string)
"Given the string value of a private RSA PEM file, this will parse it into two
returned values: An Ironclad private key, and an Ironclad public key."
(let ((key-values
(openssl-shell-destructure-private-key private-pem-string)))
(values (ironclad:make-private-key
:rsa
:n (getf key-values :n)
:e (getf key-values :e)
:d (getf key-values :d)
:p (getf key-values :p)
:q (getf key-values :q))
(ironclad:make-public-key
:rsa
:n (getf key-values :n)
:e (getf key-values :e)))))
(defun openssl-shell-sign-string (private-pem-string string)
"Use the OpenSSL binary on the host system to RSS-SHA256 sign a STRING with a
private key."
(alexandria:write-string-into-file private-pem-string #p"/tmp/private.pem" :if-does-not-exist :create :if-exists :overwrite)
(apply #'str:concat
(inferior-shell:run/lines
`(inferior-shell:pipe
(printf ,string)
(openssl dgst -sha256 -sign /tmp/private.pem -)
(base64)))))

166
src/signatures.lisp
View File

@ -1,166 +0,0 @@
;;;; activitypub-servist/signatures: Handle AP-compatible HTTP signatures.
;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at>
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU Affero General Public License
;; as published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;;
;; 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
(:use #:cl)
(:nicknames "AP-S/S")
(:export :generate-key-pair
:sign-string :import-pem-key-pair
:digest-string :string-sha256sum))
(in-package #:activitypub-servist/signatures)
;;; Key creation/parsing
;;; ————————————————————————————————————————
;; At the moment, I’ve yet to use figure out how to create PEM representations of
;; a public keypair properly in Lisp.
;; So at the moment, keys are generated into PEM files by the openssl binary on
;; the host’s system; and the output of the openssl command is used to parse into
;; Ironclad keys.
;; Yes, I know, this is absolutely horrific. Actually disgusting.
;; But at the moment,I want to focus on other core parts of ActivityPub; I’ve
;; tired of messing with ASN1 & co. That’s for another day! ^^
(defun generate-key-pair ()
"Generate a 2048-bit RSA key-pair in PEM-format using one’s `openssl` binary.
It returns two values: The private key, then the public key."
(let* ((private-pem-key (inferior-shell:run/s "openssl genrsa 2048"))
(public-pem-key
(inferior-shell:run/s
`(inferior-shell:pipe (echo ,private-pem-key)
(openssl rsa -outform PEM -pubout)))))
(values private-pem-key
public-pem-key)))
(defun destructure-openssl-private-key (pem-string &optional results)
"When passed the output of the shell command `openssl rsa -text -noout`, will
parse the output into a plist containing relavent numbers:
:n (modulus), :e (public exponent), :d (private exponent), :p (1st prime),
:q (2nd prime), :e1 (1st exponent), :e2 (2nd exponent), and :c (coefficient)."
(let* ((lines (if (stringp pem-string)
(inferior-shell:run/lines
`(inferior-shell:pipe
(echo ,pem-string)
(openssl rsa -text -noout)))
pem-string))
(line (str:trim (car lines))))
(cond
((not lines)
(mapcar
(lambda (result-item)
(if (stringp result-item)
(parse-integer (str:replace-all ":" "" result-item) :radix 16)
result-item))
results))
((str:starts-with-p "Private" line)
(openssl-shell-destructure-private-key
(cdr lines) results))
((str:starts-with-p "modulus:" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:n))))
((str:starts-with-p "prime1" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:p))))
((str:starts-with-p "prime2" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:q))))
((str:starts-with-p "exponent1" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:e1))))
((str:starts-with-p "exponent2" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:e2))))
((str:starts-with-p "coefficient" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:c))))
((str:starts-with-p "privateExponent" line)
(openssl-shell-destructure-private-key
(cdr lines) (nconc results '(:d))))
((str:starts-with-p "publicExponent" line)
(openssl-shell-destructure-private-key
(cdr lines)
(nconc
results
(list
:e
(parse-integer
(car (str:split #\space
(str:replace-first
"publicExponent: "
""
line))))))))
('t
(let* ((last-element (car (last results)))
(total-string (if (stringp last-element)
(str:concat last-element line)
line)))
(openssl-shell-destructure-private-key
(cdr lines)
(if (stringp last-element)
(nconc (reverse (cdr (reverse results)))
(list total-string))
(nconc results
(list total-string)))))))))
(defun import-pem-key-pair (private-pem-string)
"Given the string value of a private RSA PEM file, this will parse it into two
returned values: An Ironclad private key, and an Ironclad public key."
(let ((key-values
(openssl-shell-destructure-private-key private-pem-string)))
(values (ironclad:make-private-key
:rsa
:n (getf key-values :n)
:e (getf key-values :e)
:d (getf key-values :d)
:p (getf key-values :p)
:q (getf key-values :q))
(ironclad:make-public-key
:rsa
:n (getf key-values :n)
:e (getf key-values :e)))))
;;; Signing
;;; ————————————————————————————————————————
(defun sign-string (private-pem-string string)
"Use the OpenSSL binary on the host system to RSS-SHA256 sign a STRING with a
private key."
(alexandria:write-string-into-file private-pem-string #p"/tmp/private.pem" :if-does-not-exist :create :if-exists :overwrite)
(apply #'str:concat
(inferior-shell:run/lines
`(inferior-shell:pipe
(printf ,string)
(openssl dgst -sha256 -sign /tmp/private.pem -)
(base64)))))
;;; Misc.
;;; ————————————————————————————————————————
(defun digest-string (digest-spec string)
"Compute the digest of a STRING, given an Ironclad DIGEST-SPEC."
(ironclad:digest-sequence
digest-spec
(flexi-streams:string-to-octets string :external-format 'utf-8)))
(defun string-sha256sum (string)
"Compute the sha256 checksum of a STRING, in hexadecimal string-format."
(base64:usb8-array-to-base64-string
(digest-string (ironclad:make-digest :sha256) string)))

27
t/signatures.lisp
View File

@ -1,27 +0,0 @@
;;;; activitypub-servist/tests/signatures: Testing activitypub-servist/signatures.
;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at>
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU Affero General Public License
;; as published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;;
;; 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/tests/signatures
(:use :cl :lisp-unit2))
(in-package :activitypub-servist/tests/signatures)
(define-test string-sha256sum (:tags '(misc))
(assert-equal
"erws/VxJ7XO5xQBqpwHIUwG0P4q1Ek2D4N053+E2Ib8="
(ap-s/s::string-sha256sum "This is a testing string~! ♥ ĉu ne?~")))