Classes for ActivityVocab’s extended Activities

Modularization!

activitypub-servist.asd

@@ -1,5 +1,46 @@
-(defsystem "activitypub-servist"
+(require "asdf")
-  :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")))
 
-;; (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))")))

src/activity-vocabulary.lisp

@@ -0,0 +1,118 @@
+;;;; 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) ())

src/activitypub-servist.lisp

@@ -1,20 +1,23 @@
-;;; 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
-  (:use #:cl)
+  (:use #:cl #:activitypub-servist/signatures)
+  (:nicknames "AP-S")
   (:export :server :start-server))
 
 (in-package #:activitypub-servist)
@@ -24,13 +27,11 @@
   "List of the server's usernames."
   '("servistchjo"))
 
-
 (defun userhosts ()
   "List of the server's usernames + hostname."
   (mapcar (lambda (username) (str:concat username "@" "etc.xwx.moe"))
           (users)))
 
-
 (defun directories ()
   "Alist of the server's paths and their response functions."
   '(("u/" . http-user-dir)
@@ -43,9 +44,8 @@
 
 
 
-;; ————————————————————————————————————————
+;;; Host-info response
-;; Host-info response
+;;; ————————————————————————————————————————
-;; ————————————————————————————————————————
 (defun http-host-meta (&optional env path-items params)
   `(200 (:content-type "application/xrd+xml; charset=utf-8")
     (,(str:concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
@@ -58,13 +58,11 @@
 
 
 
-;; ————————————————————————————————————————
+;;; Webfinger response
-;; Webfinger response
+;;; ————————————————————————————————————————
-;; ————————————————————————————————————————
 (defun http-webfinger (env path-items params)
   (webtentacle:server env (lambda (resource) (resource-info-func resource)) nil))
 
-
 (defun resource-userhost (resource)
   "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
@@ -88,7 +86,6 @@ Ex:  acct:mom@bird.com → '(“mom” “bird.com”)"
       (pathname-name resource)
       (purl:url-host resource)))))
 
-
 (defun resource-valid-p (resource)
   "Given a webfinger-style “resource”"
   (let* ((userhost (resource-userhost resource))
@@ -98,7 +95,6 @@ Ex:  acct:mom@bird.com → '(“mom” “bird.com”)"
                    (string-equal (string-downcase a)
                                  (string-downcase b))))))
 
-
 (defun resource-info-func (resource)
   "Given a webfinger RESOURCE, return a property-list of data on the given user…
 if they exist, that is.
@@ -121,20 +117,17 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
                    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)
+  "Respond to requests within the /u/* directory."
   (let ((user (car path-items)))
     ;; In case of request for the user's actor.
     (if (member user (users) :test 'equal)
         `(200 (:content-type "application/activity+json")
               (,(user-actor env user))))))
 
-
 (defun user-actor (config username)
   "The JSON of a user's actor."
   (let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username))
@@ -175,9 +168,8 @@ Mi ne estas knabino!!")
 
 
 
-;; ————————————————————————————————————————
+;;; Sending a note
-;; Sending a note
+;;; ————————————————————————————————————————
-;; ————————————————————————————————————————
 (defun note-json (from to text)
   "The JSON of a user's actor."
   (let* ((user-root from)
@@ -198,12 +190,10 @@ Mi ne estas knabino!!")
                "content" text
                "to" (if (listp to) to (list to))))))))))
 
-
 (defvar +date-header-datetime-format+
   '(:short-weekday ", " (:day 2) " " :short-month " " (:year 4) " "
     (:hour 2) #\: (:min 2) #\: (:sec 2) " " :timezone))
 
-
 (defun note-headers (inbox from to json)
   (let* ((inbox-uri (quri:uri inbox))
          (digest-header (str:concat "SHA-256=" (string-sha256sum json)))
@@ -219,11 +209,7 @@ Mi ne estas knabino!!")
             (format nil "host: ~A~%" (quri:uri-host inbox-uri))
             (format nil "date: ~A~%" date-header)
             (format nil "digest: ~A" digest-header)))
-         (signature (base64:usb8-array-to-base64-string
+         (signature (sign-string *privkey* signed-headers))
-                     (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\","
                                        "algorithm=\"rsa-sha256\","
                                        "headers=\"(request-target) host date digest\","
@@ -236,7 +222,6 @@ Mi ne estas knabino!!")
       ("Accept" . "application/activity+json")
       ("Content-Type" . "application/activity+json"))))
 
-
 (defun send-note (inbox from to text)
   (let* ((json (note-json from to text))
          (headers (note-headers inbox from to json)))
@@ -244,11 +229,9 @@ Mi ne estas knabino!!")
                         :headers headers)))
 
 
-
 
-;; ————————————————————————————————————————
+;;; Misc. responses
-;; Misc. responses
+;;; ————————————————————————————————————————
-;; ————————————————————————————————————————
 (defun http-404 (env path-items params)
   "The default 404 response."
   '(404 (:content-type "text/plain")
@@ -256,9 +239,10 @@ Mi ne estas knabino!!")
 
 (defvar *logs* '())
 
-;; ————————————————————————————————————————
+
-;; Invocation
+
-;; ————————————————————————————————————————
+;;; Invocation
+;;; ————————————————————————————————————————
 (defun server (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))))))
@@ -275,7 +259,6 @@ Mi ne estas knabino!!")
     (or (funcall (cdr response-function) env path-sans-response-root params)
         (funcall 'http-404 env path-sans-response-root params))))
 
-
 (defun start-server (&optional (config '(:domain "localhost" :port 8080)))
   "Start the server."
   (clack:clackup (lambda (env)
@@ -286,9 +269,8 @@ Mi ne estas knabino!!")
 
 
 
-;; ————————————————————————————————————————
+;;; Utils.
-;; Utils.
+;;; ————————————————————————————————————————
-;; ————————————————————————————————————————
 (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
@@ -308,13 +290,11 @@ or “/bear/apple/” or “/bear/”, but not “/bear” (not a directory)."
                   (cdr (reverse path-items)))
            (+ depth 1))))))
 
-
 (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)))
 
-
 (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”))"
@@ -325,160 +305,13 @@ or “/bear/apple/” or “/bear/”, but not “/bear” (not a directory)."
              (cadr pair-items))))
    (str:split #\&  (cadr (str:split #\? path)))))
 
-
 (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))
 
-
-(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)
   (reduce #'str:concat
           (loop for number across
                 sequence
                 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)))))
-

src/signatures.lisp

@@ -0,0 +1,166 @@
+;;;; 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)))

t/signatures.lisp

@@ -0,0 +1,27 @@
+;;;; 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?~")))