2023-09-01 23:40:58 -05:00
|
|
|
|
;;; Copyright © 2023 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/>.
|
2023-05-25 08:59:17 -05:00
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
(defpackage #:activitypub-servist
|
|
|
|
|
(:use #:cl)
|
|
|
|
|
(:export :server :start-server))
|
2023-05-25 08:59:17 -05:00
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
(in-package #:activitypub-servist)
|
2023-05-25 08:59:17 -05:00
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
|
|
|
|
|
(defun users ()
|
|
|
|
|
"List of the server's usernames."
|
2023-12-19 23:37:33 -06:00
|
|
|
|
'("servisto"))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun userhosts ()
|
|
|
|
|
"List of the server's usernames + hostname."
|
|
|
|
|
(mapcar (lambda (username) (str:concat username "@" "etc.xwx.moe"))
|
|
|
|
|
(users)))
|
2023-09-01 22:20:13 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun directories ()
|
|
|
|
|
"Alist of the server's paths and their response functions."
|
2023-09-19 14:50:30 -05:00
|
|
|
|
'(("u/" . http-user-dir)
|
|
|
|
|
(".well-known/webfinger" . http-webfinger)
|
|
|
|
|
(".well-known/host-meta" . http-host-meta)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; 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\"?>
|
|
|
|
|
<XRD xmlns=\"http://docs.oasis-open.org/ns/xri/xrd-1.0\">
|
2023-12-19 23:37:33 -06:00
|
|
|
|
<link rel=\"lrdd\" type=\"application/xrd+xml\" template=\"https://"
|
2023-09-19 14:50:30 -05:00
|
|
|
|
(getf env :domain)
|
|
|
|
|
"/.well-known/webfinger?resource={uri}\"/>
|
|
|
|
|
</XRD>
|
|
|
|
|
"))))
|
2023-09-01 22:20:13 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; Webfinger response
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
(defun http-webfinger (env path-items params)
|
|
|
|
|
(webtentacle:server env (lambda (resource) (resource-info-func resource)) nil))
|
2023-08-31 17:59:15 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(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
|
|
|
|
|
business!
|
|
|
|
|
Ex: acct:mom@bird.com → '(“mom” “bird.com”)"
|
|
|
|
|
(cond
|
|
|
|
|
;; A @bird@mom-style resource
|
|
|
|
|
((str:containsp "@" resource)
|
|
|
|
|
(let* ((sans-acct (if (str:starts-with-p "acct:" resource)
|
|
|
|
|
(subseq resource 5)
|
|
|
|
|
resource))
|
|
|
|
|
(sans-@ (if (str:starts-with-p "@" sans-acct)
|
|
|
|
|
(subseq sans-acct 1)
|
|
|
|
|
sans-acct)))
|
|
|
|
|
(destructuring-bind (user host)
|
|
|
|
|
(str:split "@" sans-@)
|
|
|
|
|
(cons user host))))
|
|
|
|
|
;; A URL-style resource
|
|
|
|
|
((str:containsp "/u/" resource)
|
|
|
|
|
(cons
|
|
|
|
|
(pathname-name resource)
|
|
|
|
|
(purl:url-host resource)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun resource-valid-p (resource)
|
|
|
|
|
"Given a webfinger-style “resource”"
|
|
|
|
|
(let* ((userhost (resource-userhost resource))
|
|
|
|
|
(userhost-str (funcall #'str:concat (car userhost) "@" (cdr userhost))))
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(member userhost-str (userhosts)
|
2023-08-31 17:59:15 -05:00
|
|
|
|
:test (lambda (a b)
|
|
|
|
|
(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.
|
|
|
|
|
This is used by the WEBTENTACLE webfinger server; you can see information on
|
|
|
|
|
the plist in the docstring for its WEBTENTACLE:SERVER function."
|
|
|
|
|
(let* ((userhost (resource-userhost resource))
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(profile (str:concat "https://" (cdr userhost) "/u/" (car userhost))))
|
2023-08-31 17:59:15 -05:00
|
|
|
|
(when (resource-valid-p resource)
|
|
|
|
|
(list
|
2023-12-19 23:37:33 -06:00
|
|
|
|
:subject (str:concat "acct:" (car userhost) "@" (cdr userhost))
|
|
|
|
|
:aliases `(,profile)
|
2023-08-31 17:59:15 -05:00
|
|
|
|
:links
|
|
|
|
|
`((href ,profile
|
2023-12-19 23:37:33 -06:00
|
|
|
|
rel "self"
|
|
|
|
|
type "application/activity+json")
|
2023-08-31 17:59:15 -05:00
|
|
|
|
(href ,profile
|
2023-12-19 23:37:33 -06:00
|
|
|
|
rel "self"
|
2024-03-24 10:58:09 -05:00
|
|
|
|
type "application/activity+json")
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(template ,(str:concat "https://" (cdr userhost) "/ostatus_subscribe?acct={uri}")
|
|
|
|
|
rel "http://ostatus.org/schema/1.0/subscribe"))))))
|
|
|
|
|
|
2023-05-27 23:31:05 -05:00
|
|
|
|
|
2023-05-25 08:59:17 -05:00
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; User info response(s)
|
|
|
|
|
;; ————————————————————————————————————————
|
2023-05-25 08:59:17 -05:00
|
|
|
|
;; Respond to requests within the /u/* directory.
|
|
|
|
|
(defun http-user-dir (env path-items params)
|
|
|
|
|
(let ((user (car path-items)))
|
|
|
|
|
;; In case of request for the user's actor.
|
|
|
|
|
(if (member user (users) :test 'string=)
|
2024-03-24 10:58:09 -05:00
|
|
|
|
`(200 (:content-type "application/activity+json")
|
2023-05-25 22:46:44 -05:00
|
|
|
|
(,(user-actor env user))))))
|
|
|
|
|
|
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
(defun user-actor (config username)
|
|
|
|
|
"The JSON of a user's actor."
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username))
|
|
|
|
|
(yason:*symbol-encoder* 'yason:encode-symbol-as-lowercase))
|
2023-09-01 22:20:13 -05:00
|
|
|
|
(yason:with-output-to-string* ()
|
|
|
|
|
(yason:encode-alist
|
|
|
|
|
`(("@context" . ("https://www.w3.org/ns/activitystreams"
|
2023-12-19 23:37:33 -06:00
|
|
|
|
"https://litepub.social/litepub/context.jsonld"))
|
2023-09-01 22:20:13 -05:00
|
|
|
|
("id" . ,user-root)
|
|
|
|
|
("type" . "Person")
|
|
|
|
|
("preferredUsername" . ,username)
|
2023-12-19 23:37:33 -06:00
|
|
|
|
("name" . "Servistiĉo")
|
2023-09-01 22:20:13 -05:00
|
|
|
|
("inbox" . ,(str:concat user-root "/inbox.json"))
|
2023-12-19 23:37:33 -06:00
|
|
|
|
("outbox" . ,(str:concat user-root "/outbox.json"))
|
|
|
|
|
("summary" . "Mi estas simpla roboto, kiu montras ke iomete ekfunkcias activitypub-servist.
|
|
|
|
|
… ĉu mi rajtas demeti la servistinan kostumon, nun?
|
|
|
|
|
Mi ne estas knabino!!")
|
|
|
|
|
("icon"
|
|
|
|
|
. ,(alexandria:plist-hash-table
|
|
|
|
|
(list
|
|
|
|
|
"type" "Image"
|
|
|
|
|
"url" "https://xwx.moe/etc/servisticho-profilbildo.png")))
|
|
|
|
|
("image"
|
|
|
|
|
. ,(alexandria:plist-hash-table
|
|
|
|
|
(list
|
|
|
|
|
"type" "Image"
|
|
|
|
|
"url" "https://xwx.moe/etc/servisticho-standardo.png")))
|
|
|
|
|
("publicKey"
|
|
|
|
|
. ,(alexandria:plist-hash-table
|
|
|
|
|
(list
|
|
|
|
|
"id" (str:concat user-root "#main-key")
|
|
|
|
|
"owner" user-root
|
|
|
|
|
"publicKeyPem" *pubkey*))))))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; Sending a note
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
(defun note-json (from to text)
|
|
|
|
|
"The JSON of a user's actor."
|
|
|
|
|
(let* ((user-root (str:concat "https://etc.xwx.moe/u/" from))
|
|
|
|
|
(yason:*symbol-encoder* 'yason:encode-symbol-as-lowercase))
|
|
|
|
|
(yason:with-output-to-string* ()
|
|
|
|
|
(yason:encode-alist
|
|
|
|
|
`(("@context" . ("https://www.w3.org/ns/activitystreams"
|
|
|
|
|
"https://litepub.social/litepub/context.jsonld"))
|
|
|
|
|
("id" . ,(format nil "~A" (random 900000)))
|
|
|
|
|
("actor" . ,user-root)
|
|
|
|
|
("type" . "Create")
|
|
|
|
|
("object"
|
|
|
|
|
. ,(alexandria:plist-hash-table
|
|
|
|
|
(list
|
|
|
|
|
"id" (format nil "~A" (random 900000))
|
|
|
|
|
"type" "Note"
|
|
|
|
|
"attributedTo" user-root
|
|
|
|
|
"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 text)
|
|
|
|
|
(let* ((json (note-json from to text))
|
|
|
|
|
(inbox-uri (quri:uri inbox))
|
|
|
|
|
(digest-header (str:concat "SHA-256=" (string-sha256sum json)))
|
|
|
|
|
(date-header
|
|
|
|
|
(let ((local-time:*default-timezone* local-time:+gmt-zone+))
|
|
|
|
|
(local-time:format-timestring
|
|
|
|
|
nil (local-time:now)
|
|
|
|
|
:format +date-header-datetime-format+)))
|
|
|
|
|
(signed-headers (str:unlines
|
|
|
|
|
(list
|
|
|
|
|
(str:concat "(request target): post " (quri:uri-path inbox-uri))
|
|
|
|
|
(str:concat "host: " (quri:uri-host inbox-uri))
|
|
|
|
|
(str:concat "date: " date-header)
|
|
|
|
|
(str:concat "digest: " digest-header))))
|
|
|
|
|
(signature (base64:usb8-array-to-base64-string
|
|
|
|
|
(ironclad:sign-message (openssl-shell-import-key-pair *privkey*)
|
|
|
|
|
(string-to-ub8-vector signed-headers))))
|
|
|
|
|
(signature-header (str:concat "keyId=\"" from "#main-key\","
|
|
|
|
|
"headers=\"(request-target) host date digest\","
|
|
|
|
|
"algorithm=\"rsa-sha256\","
|
|
|
|
|
"signature=\"" signature "\"")))
|
|
|
|
|
`(("Date" . ,date-header)
|
|
|
|
|
("Digest" . ,digest-header)
|
|
|
|
|
("Signature" . ,signature-header)
|
|
|
|
|
("Host" . ,(quri:uri-host inbox-uri))
|
|
|
|
|
("Content-Length" . ,(length json))
|
2024-03-24 10:58:09 -05:00
|
|
|
|
("Accept" . "application/activity+json")
|
|
|
|
|
("Content-Type" . "application/activity+json"))))
|
2023-12-19 23:37:33 -06:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun send-note (inbox from to text)
|
|
|
|
|
(dexador:post inbox :content (note-json from to text)
|
|
|
|
|
:headers (note-headers inbox from to text)))
|
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; Misc. responses
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
(defun http-404 (env path-items params)
|
|
|
|
|
"The default 404 response."
|
|
|
|
|
'(404 (:content-type "text/plain")
|
|
|
|
|
("404, you goddamn fool!")))
|
|
|
|
|
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(defvar *logs* '())
|
2023-05-25 08:59:17 -05:00
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; Invocation
|
|
|
|
|
;; ————————————————————————————————————————
|
2023-05-25 08:59:17 -05:00
|
|
|
|
(defun server (env)
|
2023-09-01 22:20:13 -05:00
|
|
|
|
"Returns the response data for Clack, given the request data `env`."
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(setq *logs* (append *logs* (list env)))
|
2023-05-25 15:59:10 -05:00
|
|
|
|
(let* ((path (pathname-sans-parameters (getf env :request-uri)))
|
|
|
|
|
(params (pathname-parameters (getf env :request-uri)))
|
2023-05-25 08:59:17 -05:00
|
|
|
|
(response-function
|
2023-05-25 15:59:10 -05:00
|
|
|
|
(or (assoc-by-path (directories) (pathname-components path))
|
2023-05-25 08:59:17 -05:00
|
|
|
|
'("" . http-404)))
|
|
|
|
|
;; So that response functions only deal with relative paths…
|
|
|
|
|
(path-sans-response-root
|
|
|
|
|
(pathname-components
|
|
|
|
|
(str:replace-first (car response-function) "" path))))
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(format nil "Path: ~s" path)
|
2023-05-25 08:59:17 -05:00
|
|
|
|
(or (funcall (cdr response-function) env path-sans-response-root params)
|
|
|
|
|
(funcall 'http-404 env path-sans-response-root params))))
|
|
|
|
|
|
|
|
|
|
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(defun start-server (&optional (config '(:domain "etc.xwx.moe")))
|
2023-09-01 22:20:13 -05:00
|
|
|
|
"Start the server."
|
2023-05-27 23:31:05 -05:00
|
|
|
|
(clack:clackup (lambda (env)
|
2023-08-31 17:59:15 -05:00
|
|
|
|
(server (append env config)))
|
2023-05-27 23:31:05 -05:00
|
|
|
|
:server 'woo
|
|
|
|
|
:address "0.0.0.0"
|
2023-12-19 23:37:33 -06:00
|
|
|
|
:port (getf config :port)))
|
2023-05-25 08:59:17 -05:00
|
|
|
|
|
|
|
|
|
|
2023-09-01 22:20:13 -05:00
|
|
|
|
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; Utils.
|
|
|
|
|
;; ————————————————————————————————————————
|
2023-05-25 08:59:17 -05:00
|
|
|
|
(defun assoc-by-path (alist path-items &optional (depth 0))
|
2023-09-01 22:20:13 -05:00
|
|
|
|
"Given an associative list and a path decomposed into a list of
|
|
|
|
|
its components, return the item with the closest according
|
|
|
|
|
pathname as key. If the exact path isn't a valid key, it will
|
|
|
|
|
try all parent directories.
|
|
|
|
|
E.g., “/bear/apple/momma/” could match either “/bear/apple/momma”
|
|
|
|
|
or “/bear/apple/” or “/bear/”, but not “/bear” (not a directory)."
|
2023-05-25 08:59:17 -05:00
|
|
|
|
(let ((path (str:join #\/ path-items)))
|
|
|
|
|
(if (eq path-items nil)
|
|
|
|
|
(assoc "" alist :test 'string=)
|
|
|
|
|
(or (and (eq depth 0)
|
|
|
|
|
(assoc path alist :test 'string=))
|
|
|
|
|
(assoc (str:concat path "/")
|
|
|
|
|
alist :test 'string=)
|
|
|
|
|
(assoc-by-path
|
|
|
|
|
alist (reverse
|
|
|
|
|
(cdr (reverse path-items)))
|
|
|
|
|
(+ depth 1))))))
|
|
|
|
|
|
|
|
|
|
|
2023-05-25 15:59:10 -05:00
|
|
|
|
(defun pathname-sans-parameters (path)
|
2023-09-01 22:20:13 -05:00
|
|
|
|
"Removes parameters from a URI pathname, returning the bare path.
|
|
|
|
|
“/path/a/b?a=1&b=3” → “/path/a/b”"
|
2023-05-25 15:59:10 -05:00
|
|
|
|
(car (str:split #\? path)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun pathname-parameters (path)
|
2023-09-01 22:20:13 -05:00
|
|
|
|
"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”))"
|
2023-05-25 15:59:10 -05:00
|
|
|
|
(mapcar
|
|
|
|
|
(lambda (pair)
|
|
|
|
|
(let ((pair-items (str:split #\= pair)))
|
|
|
|
|
(cons (car pair-items)
|
|
|
|
|
(cadr pair-items))))
|
|
|
|
|
(str:split #\& (cadr (str:split #\? path)))))
|
|
|
|
|
|
|
|
|
|
|
2023-05-25 08:59:17 -05:00
|
|
|
|
(defun pathname-components (pathname)
|
2023-09-01 22:20:13 -05:00
|
|
|
|
"Split a pathname into a list of its components.
|
|
|
|
|
“/u/bear/apple.txt” → '(“u” “bear” “apple.txt”)"
|
2023-05-25 08:59:17 -05:00
|
|
|
|
(str:split #\/ pathname :omit-nulls 't))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
|
|
|
|
|
|
2023-12-19 23:37:33 -06:00
|
|
|
|
(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))))
|
|
|
|
|
|
|
|
|
|
|
2023-09-14 18:45:03 -05:00
|
|
|
|
|
|
|
|
|
;; ————————————————————————————————————————
|
|
|
|
|
;; 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.
|
2023-09-14 22:34:15 -05:00
|
|
|
|
;; 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)
|
2023-09-14 18:45:03 -05:00
|
|
|
|
"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)."
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(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))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
(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)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) results))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "modulus:" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) (nconc results '(:n))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "prime1" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) (nconc results '(:p))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "prime2" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) (nconc results '(:q))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "exponent1" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) (nconc results '(:e1))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "exponent2" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) (nconc results '(:e2))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "coefficient" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) (nconc results '(:c))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "privateExponent" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
|
|
|
|
(cdr lines) (nconc results '(:d))))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
((str:starts-with-p "publicExponent" line)
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key
|
2023-09-14 18:45:03 -05:00
|
|
|
|
(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)))
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(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."
|
2023-09-14 18:45:03 -05:00
|
|
|
|
(let ((key-values
|
2023-09-14 22:34:15 -05:00
|
|
|
|
(openssl-shell-destructure-private-key private-pem-string)))
|
2023-09-14 18:45:03 -05:00
|
|
|
|
(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
|
2023-09-14 22:34:15 -05:00
|
|
|
|
:rsa
|
|
|
|
|
:n (getf key-values :n)
|
|
|
|
|
:e (getf key-values :e)))))
|