Begin an example server

Only Webfinger is properly supported and working,
so far!

docs/examples/simple-server.lisp

@@ -0,0 +1,150 @@
+;;;; simple-server: A bare-bones example ActivityPub instance.
+
+;; Written in 2024 by Jaidyn Levesque <jadedctrl@posteo.at>
+;;
+;; To the extent possible under law, the author(s) have dedicated
+;; all copyright and related and neighboring rights to this
+;; software to the public domain worldwide. This software is
+;; distributed without any warranty.
+;;
+;; You should have received a copy of the CC0 Public Domain
+;; Dedication along with this software. If not, see
+;; <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+(defpackage #:activitypub-example
+  (:use #:cl)
+  (:export :start-server :seed)
+  ;; Note that we use a nickname for the ActivityStreams vocab!
+  ;; I recommend doing likewise; save yourself some typing!
+  (:local-nicknames (:as :activity-servist/vocab/activity)))
+
+(in-package #:activitypub-example)
+
+
+;;; Globals
+;;; ————————————————————————————————————————
+(defvar *store* (make-hash-table :test #'equal)
+  "Our “object-store” — stores all ActivityPub objects, mapped by their IRI @ID.")
+
+(defvar *config* '(:address "localhost" :protocol "http" :port 8080 :fetch fetch))
+
+(defvar *user-id-format* "~A://~A/users/~A"
+  "The format we use for user’s @IDs/URIs.
+The first parameter is the protocol, the second the host, and the third the username.
+For example: “https://localhost:8080/users/lena”.")
+
+
+
+;;; Invocation
+;;; ————————————————————————————————————————
+(defun start-server ()
+  "Start the server; simple and to-the-point."
+  (clack:clackup
+   (lambda (env)
+     (let ((activity-servist:*config* *config*))
+       (activity-servist:server env)))
+   :server  'woo
+   :address (getf *config* :address)
+   :port    (getf *config* :port)))
+
+(defun seed ()
+  "Seed our server with some random users, for testing purposes."
+  (save (make-user "maria" "Maria ♥"))
+  (save (make-user "melanie" "Melanie >:o"))
+  (save (make-user "jorge" "Jorge 🦆")))
+
+
+
+;;; Activity-Servist callbacks
+;;; ————————————————————————————————————————
+(defun fetch (uri)
+  "activity-servist callback); returns the JSON-LD-OBJECT of the given @ID or URI.
+This example server simply stores objects in a hash-table mapping IDs to objects."
+  (let ((id (or (uri->id uri) uri)))
+    (gethash id *store*)))
+
+
+
+;;; ID-management
+;;; ————————————————————————————————————————
+(defun uri->id (uri-str)
+  "Returns an object’s @ID corresponding to the URI string.
+For most cases, returning URI-STR directly is what you want. But there are two exceptions:
+  • Account URIs of format “acct:username@host.tld”, as used by WebFinger.
+  • Aliases, if an object can be accessed through several URIs.
+
+This example only handles the first exception, acct: URIs."
+  (let* ((uri    (quri:uri uri-str))
+         (scheme (quri:uri-scheme uri)))
+    (if (or (not scheme)
+            (equal scheme "acct"))
+        (acct-uri->id uri)
+        uri-str)))
+
+(defun acct-uri->id (uri)
+  "Helper-function for URI->ID. Returns the @ID of an acct:-format URI.
+That is, an “acct:username@host.tld” URI."
+  (let* ((path             (quri:uri-path uri))
+         (sans-preceding-@ (if (str:starts-with-p "@" path)
+                               (subseq path 1)
+                               path)))
+    (destructuring-bind (user host)
+        (str:split "@" sans-preceding-@)
+      (format nil *user-id-format*
+              (host-scheme host) host user))))
+
+(defun host-scheme (hostname)
+  "Helper-function for ACCT-URI->ID. Returns the expected protocol of a hostname.
+If it’s our configured :ADDRESS (in *CONFIG*), then return *CONFIG*’s :PROTOCOL.
+Otherwise, assume “https”."
+  (if (equal (getf *config* :address) hostname)
+      (getf *config* :protocol)
+      "https"))
+
+
+
+;;; Data-management
+;;; ————————————————————————————————————————
+(defun save (obj)
+  "Save an object to our object-store, *STORE*."
+  (setf (gethash (json-ld:@id obj) *store*) obj))
+
+
+
+;;; Users
+;;; ————————————————————————————————————————
+(defclass user (as:person)
+  ((inbox
+    :accessor user-inbox
+    :initform nil
+    :documentation "A list of objects in the user’s inbox.")
+   (outbox
+    :accessor user-outbox
+    :initform nil
+    :documentation "A list of objects in the user’s outbox.")
+   (following
+     :accessor user-following
+     :initform nil
+     :documentation "A list of Actor objects that the user is following.")
+   (followers
+    :accessor user-followers
+    :initform nil
+    :documentation "A list of Actor objects that follow the user.")))
+
+(defun make-user (username nickname)
+  "Create a USER of the given USERNAME and NICKNAME.
+The ID and ENDPOINTS are derived using the parameter USERNAME and the global *USER-ID-FORMAT*."
+  (let ((obj (make-instance 'user))
+        (uri (format nil *user-id-format*
+                     (getf *config* :protocol)
+                     (getf *config* :address)
+                     username)))
+    (flet ((sub-uri (path)
+             (format nil "~A/~A" uri path)))
+      (setf (as:name obj)      username)
+      (setf (json-ld:@id obj)  uri)
+      (setf (as:inbox obj)     (sub-uri "inbox"))
+      (setf (as:outbox obj)    (sub-uri "outbox"))
+      (setf (as:following obj) (sub-uri "following"))
+      (setf (as:followers obj) (sub-uri "followers")))
+   obj))