Begin authorization; tweak webfinger & user-profs

Tweaks webfinger output & user-profile data to be
more along the lines of Mastodon et. al.

Also contains the beginnings of
signature-generation required for actually sending
messages.
This commit is contained in:
Jaidyn Ann 2023-12-19 23:37:33 -06:00
parent f48d5ed8c2
commit 05fd026c84
2 changed files with 143 additions and 16 deletions

View File

@ -1,3 +1,5 @@
(defsystem "activitypub-servist" (defsystem "activitypub-servist"
:depends-on ("alexandria" "clack" "inferior-shell" "ironclad" "purl" "str" "webtentacle" "yason") :depends-on ("alexandria" "clack" "dexador" "inferior-shell" "ironclad" "local-time" "purl" "str" "webtentacle" "yason")
:components ((:file "activitypub-servist"))) :components ((:file "activitypub-servist")))
;; (ql:quickload '(alexandria clack dexador inferior-shell ironclad local-time purl str webtentacle yason))

View File

@ -22,7 +22,13 @@
(defun users () (defun users ()
"List of the server's usernames." "List of the server's usernames."
'("rod@localhost" "mum@localhost")) '("servisto"))
(defun userhosts ()
"List of the server's usernames + hostname."
(mapcar (lambda (username) (str:concat username "@" "etc.xwx.moe"))
(users)))
(defun directories () (defun directories ()
@ -40,7 +46,7 @@
`(200 (:content-type "application/xrd+xml; charset=utf-8") `(200 (:content-type "application/xrd+xml; charset=utf-8")
(,(str:concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?> (,(str:concat "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<XRD xmlns=\"http://docs.oasis-open.org/ns/xri/xrd-1.0\"> <XRD xmlns=\"http://docs.oasis-open.org/ns/xri/xrd-1.0\">
<link rel=\"lrdd\" template=\"https://" <link rel=\"lrdd\" type=\"application/xrd+xml\" template=\"https://"
(getf env :domain) (getf env :domain)
"/.well-known/webfinger?resource={uri}\"/> "/.well-known/webfinger?resource={uri}\"/>
</XRD> </XRD>
@ -83,7 +89,7 @@ Ex: acct:mom@bird.com → '(“mom” “bird.com”)"
"Given a webfinger-style “resource”" "Given a webfinger-style “resource”"
(let* ((userhost (resource-userhost resource)) (let* ((userhost (resource-userhost resource))
(userhost-str (funcall #'str:concat (car userhost) "@" (cdr userhost)))) (userhost-str (funcall #'str:concat (car userhost) "@" (cdr userhost))))
(member userhost-str (users) (member userhost-str (userhosts)
:test (lambda (a b) :test (lambda (a b)
(string-equal (string-downcase a) (string-equal (string-downcase a)
(string-downcase b)))))) (string-downcase b))))))
@ -95,18 +101,21 @@ if they exist, that is.
This is used by the WEBTENTACLE webfinger server; you can see information on This is used by the WEBTENTACLE webfinger server; you can see information on
the plist in the docstring for its WEBTENTACLE:SERVER function." the plist in the docstring for its WEBTENTACLE:SERVER function."
(let* ((userhost (resource-userhost resource)) (let* ((userhost (resource-userhost resource))
(profile (str:concat "https://" (cdr userhost) "/users/" resource))) (profile (str:concat "https://" (cdr userhost) "/u/" (car userhost))))
(when (resource-valid-p resource) (when (resource-valid-p resource)
(list (list
:subject resource :subject (str:concat "acct:" (car userhost) "@" (cdr userhost))
:aliases `(,profile)
:links :links
`((href ,profile `((href ,profile
rel "http://webfinger.net/rel/profile-page" rel "self"
type "text/html" type "application/activity+json")
properties (:apple 3 :bear 4))
(href ,profile (href ,profile
rel "self" rel "self"
type "application/activity+json")))))) 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"))))))
@ -124,16 +133,103 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
(defun user-actor (config username) (defun user-actor (config username)
"The JSON of a user's actor." "The JSON of a user's actor."
(let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username))) (let* ((user-root (str:concat "https://" (getf config :domain) "/u/" username))
(yason:*symbol-encoder* 'yason:encode-symbol-as-lowercase))
(yason:with-output-to-string* () (yason:with-output-to-string* ()
(yason:encode-alist (yason:encode-alist
`(("@context" . ("https://www.w3.org/ns/activitystreams" `(("@context" . ("https://www.w3.org/ns/activitystreams"
"https://w3id.org/security/v1")) "https://litepub.social/litepub/context.jsonld"))
("id" . ,user-root) ("id" . ,user-root)
("type" . "Person") ("type" . "Person")
("preferredUsername" . ,username) ("preferredUsername" . ,username)
("name" . "Servistiĉo")
("inbox" . ,(str:concat user-root "/inbox.json")) ("inbox" . ,(str:concat user-root "/inbox.json"))
("outbox" . ,(str:concat user-root "/outbox.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)))
@ -145,12 +241,14 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
'(404 (:content-type "text/plain") '(404 (:content-type "text/plain")
("404, you goddamn fool!"))) ("404, you goddamn fool!")))
(defvar *logs* '())
;; ———————————————————————————————————————— ;; ————————————————————————————————————————
;; Invocation ;; Invocation
;; ———————————————————————————————————————— ;; ————————————————————————————————————————
(defun server (env) (defun server (env)
"Returns the response data for Clack, given the request data `env`." "Returns the response data for Clack, given the request data `env`."
(setq *logs* (append *logs* (list env)))
(let* ((path (pathname-sans-parameters (getf env :request-uri))) (let* ((path (pathname-sans-parameters (getf env :request-uri)))
(params (pathname-parameters (getf env :request-uri))) (params (pathname-parameters (getf env :request-uri)))
(response-function (response-function
@ -160,17 +258,18 @@ the plist in the docstring for its WEBTENTACLE:SERVER function."
(path-sans-response-root (path-sans-response-root
(pathname-components (pathname-components
(str:replace-first (car response-function) "" path)))) (str:replace-first (car response-function) "" path))))
(format nil "Path: ~s" path)
(or (funcall (cdr response-function) env path-sans-response-root params) (or (funcall (cdr response-function) env path-sans-response-root params)
(funcall 'http-404 env path-sans-response-root params)))) (funcall 'http-404 env path-sans-response-root params))))
(defun start-server (&optional (config '(:domain "localhost"))) (defun start-server (&optional (config '(:domain "etc.xwx.moe")))
"Start the server." "Start the server."
(clack:clackup (lambda (env) (clack:clackup (lambda (env)
(server (append env config))) (server (append env config)))
:server 'woo :server 'woo
:address "0.0.0.0" :address "0.0.0.0"
:port 8080)) :port (getf config :port)))
@ -220,6 +319,32 @@ or “/bear/apple/” or “/bear/”, but not “/bear” (not a directory)."
(str:split #\/ pathname :omit-nulls 't)) (str:split #\/ pathname :omit-nulls 't))
(defun string-to-ub8-vector (string)
"Convert the given STRING into an unsigned 8-bit vector."
(coerce
(loop for char across string
collect (char-code char))
'(vector (unsigned-byte 8))))
(defun digest-string (digest-spec string)
"Compute the digest of a STRING, given an Ironclad DIGEST-SPEC."
(ironclad:digest-sequence digest-spec (string-to-ub8-vector string)))
(defun string-sha256sum (string)
"Compute the sha256 checksum of a STRING, in hexadecimal string-format."
(base64:usb8-array-to-base64-string
(digest-string (ironclad:make-digest :sha256) string)))
(defun sequence-hexadecimal-string (sequence)
(reduce #'str:concat
(loop for number across
sequence
collect (format nil "~X" number))))
;; ———————————————————————————————————————— ;; ————————————————————————————————————————
;; RSA keys ;; RSA keys