;;; Copyright © 2023 Jaidyn Levesque ;;; ;;; 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 . (defpackage #:activitypub-servist (:use #:cl) (:export :server :start-server)) (in-package #:activitypub-servist) (defun users () "List of the server's usernames." '("servisto")) (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) (".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 " ")))) ;; ———————————————————————————————————————— ;; 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 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)))) (member userhost-str (userhosts) :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)) (profile (str:concat "https://" (cdr userhost) "/u/" (car userhost)))) (when (resource-valid-p resource) (list :subject (str:concat "acct:" (car userhost) "@" (cdr userhost)) :aliases `(,profile) :links `((href ,profile rel "self" type "application/activity+json") (href ,profile rel "self" type "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"") (template ,(str:concat "https://" (cdr userhost) "/ostatus_subscribe?acct={uri}") rel "http://ostatus.org/schema/1.0/subscribe")))))) ;; ———————————————————————————————————————— ;; User info response(s) ;; ———————————————————————————————————————— ;; 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=) `(200 (:content-type "application/ld+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)) (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" . ,user-root) ("type" . "Person") ("preferredUsername" . ,username) ("name" . "Servistiĉo") ("inbox" . ,(str:concat user-root "/inbox.json")) ("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)) ("Content-Type" . "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"")))) (defun send-note (inbox from to text) (dexador:post inbox :content (note-json from to text) :headers (note-headers inbox from to text))) ;; ———————————————————————————————————————— ;; Misc. responses ;; ———————————————————————————————————————— (defun http-404 (env path-items params) "The default 404 response." '(404 (:content-type "text/plain") ("404, you goddamn fool!"))) (defvar *logs* '()) ;; ———————————————————————————————————————— ;; Invocation ;; ———————————————————————————————————————— (defun server (env) "Returns the response data for Clack, given the request data `env`." (setq *logs* (append *logs* (list env))) (let* ((path (pathname-sans-parameters (getf env :request-uri))) (params (pathname-parameters (getf env :request-uri))) (response-function (or (assoc-by-path (directories) (pathname-components path)) '("" . http-404))) ;; So that response functions only deal with relative paths… (path-sans-response-root (pathname-components (str:replace-first (car response-function) "" path)))) (format nil "Path: ~s" path) (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 "etc.xwx.moe"))) "Start the server." (clack:clackup (lambda (env) (server (append env config))) :server 'woo :address "0.0.0.0" :port (getf config :port))) ;; ———————————————————————————————————————— ;; 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 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)." (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)))))) (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”))" (mapcar (lambda (pair) (let ((pair-items (str:split #\= pair))) (cons (car pair-items) (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)))))