Begin parsing of ActivityPub JSON objects

It is naïve and error-prone, but it works somewhat well!
What remains, primarily, is error-handling.
This commit is contained in:
Jaidyn Ann 2024-06-19 22:08:31 -05:00
parent 780951faaa
commit 75e3a964a8

View File

@ -22,6 +22,10 @@
;; One should never USE this package, since some class-names shadow ;; One should never USE this package, since some class-names shadow
;; core Common Lisp symbols! Beware! :P ;; core Common Lisp symbols! Beware! :P
(:export (:export
;; Functions
:parse
;; Globals
:*ap-packages*
;; Classes ;; Classes
:accept :activity :add :announce :application :arrive :article :audio :accept :activity :add :announce :application :arrive :article :audio
:collection :collection-page :create :delete :dislike :document :event :flag :collection :collection-page :create :delete :dislike :document :event :flag
@ -59,11 +63,18 @@
;;; Globals ;;; Globals
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
;; Used in YASON:ENCODE to ensure that a single top-level @context can be (defparameter *ap-packages* (list *package*)
;; created where AP objects contain other AP objects in their slots. "A list of packages in which we should search for AP classes and slot-symbols
;; This variable is overridden locally (LET), and should never be during JSON parsing. The class-name searched for is simply the value of the JSON
;; modified globally (as we expect it to be nil in top-level objects). objects type key. The package first in the list to export such a symbol
(defparameter *@context* nil) is the winner.")
;; Private, internal variable.
(defparameter *@context* nil
"Used in YASON:ENCODE to ensure that a single top-level @context can be
created where AP objects contain other AP objects in their slots.
This variable is overridden locally during encoding (LET), and should never be
modified globally (as we expect it to be nil in top-level objects.")
@ -244,16 +255,67 @@ to us) removed."
items in each will be contained in the resultant list." items in each will be contained in the resultant list."
(append a (remove-if (lambda (item) (find item a :test #'equal)) b))) (append a (remove-if (lambda (item) (find item a :test #'equal)) b)))
(defun find-registered-symbols (str)
"Find all symbols identified by string STR within packages in the
*ap-packages* list."
(mapcar (lambda (package) (find-symbol (string-upcase str) package))
*ap-packages*))
(defun find-registered-classes (str)
"Find all classes identified by string STR within pacakges in the
*ap-packages* list."
(mapcar (lambda (sym) (find-class sym))
(find-registered-symbols str)))
;;; JSON parsing
;;; ————————————————————————————————————————
(defun parse (string)
"Parse a string containing JSON into an ActivityPub object."
(parse-table (yason:parse string)))
(defun parse-table (table)
"Parse a hash-table corresponding to YASON-parsed JSON into an ActivityPub object."
(let* ((class (car (find-registered-classes (gethash "type" table))))
(obj (make-instance class)))
(loop for key being each hash-key of table
for val being each hash-value of table
do (let ((slot-sym (car (find-registered-symbols key)))
(val (parse-value val)))
(when slot-sym
(setf (slot-value obj slot-sym) val))))
obj))
(defun parse-value (val)
"Parse the value of a key found in YASON-parsed JSON.
All ActivityPub objects (hash-tables containing type) will be parsed into
ActivityPub objects; all others will parsed into associative lists."
(typecase val
(hash-table (maybe-parse-table val))
(list (mapcar (lambda (a)
(if (hash-table-p a)
(maybe-parse-table a)
a))
val))
(t val)))
(defun maybe-parse-table (table)
"If a hash-table seems to be a valid ActivityPub object, attempt parsing it
into one. Otherwise, parse it into an associative list."
(if (gethash "type" table)
(parse-table table)
(alexandria:hash-table-alist table)))
;;; JSON serialization ;;; JSON serialization
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defmethod yason:encode ((obj object) &optional (stream *standard-output*)) (defmethod yason:encode ((obj object) &optional (stream *standard-output*))
(yason:with-output (stream)
(yason:with-object () (yason:with-object ()
(if *@context* (if *@context* ; If this object is nested in another, use old context.
(yason:encode-object obj) (yason:encode-object obj)
(let ((*@context* (slot-value obj '@context))) (let ((*@context* (slot-value obj '@context))) ; Unnested, so create context.
(yason:encode-object obj) (yason:encode-object obj)
(yason:encode-object-element (yason:encode-object-element
"@context" "@context"
@ -261,7 +323,7 @@ items in each will be contained in the resultant list."
(yason:encode-object-element (yason:encode-object-element
"type" "type"
(or (object-type obj) (or (object-type obj)
(class-pretty-name (class-of obj))))))) (class-pretty-name (class-of obj))))))
(defun class-slots-to-camel-cased-strings-alist (class) (defun class-slots-to-camel-cased-strings-alist (class)
"Return an associative list of a CLASSes direct slots (by symbol) matched with "Return an associative list of a CLASSes direct slots (by symbol) matched with