Compare commits
7 Enmetoj
6852d63a43
...
a604d74b5b
| Author | SHA1 | Date | |
|---|---|---|---|
 Jaidyn Ann
|
a604d74b5b | ||
|
Jaidyn Ann
|
984b3d5b2a | ||
|
Jaidyn Ann
|
4339dca96e | ||
|
Jaidyn Ann
|
4287ff4cd3 | ||
|
Jaidyn Ann
|
ee06e1e80d | ||
|
Jaidyn Ann
|
94ff3fa326 | ||
|
Jaidyn Ann
|
566b5e696c |
|
|
@ -1,5 +1,46 @@
|
|||
(defsystem "activitypub-servist"
|
||||
:depends-on ("alexandria" "clack" "dexador" "inferior-shell" "ironclad" "local-time" "purl" "str" "webtentacle" "yason")
|
||||
(require "asdf")
|
||||
|
||||
|
||||
(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))")))
|
||||
|
|
|
|||
|
|
@ -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) ())
|
||||
|
|
@ -1,20 +1,23 @@
|
|||
;;; 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/>.
|
||||
;;;; activitypub-servist: An ActivityPub server framework.
|
||||
|
||||
;; 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
|
||||
(: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)
|
||||
;; ————————————————————————————————————————
|
||||
;; Respond to requests within the /u/* directory.
|
||||
;;; User info response(s)
|
||||
;;; ————————————————————————————————————————
|
||||
(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
|
||||
(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 (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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -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?~")))
|
||||
Ŝarĝante…
Reference in New Issue