Fix serializing @context & type in nested objects

src/activity-vocabulary.lisp

@@ -36,6 +36,7 @@
    :tentative-accept :tentative-reject :tombstone :travel :undo :update :video
    :view
    ;; Slots
+   :@context :type
    :activity-actor :activity-instrument :activity-object :activity-origin
    :activity-result :activity-target
    :collection-current :collection-first :collection-items :collection-last
@@ -112,22 +113,29 @@ of NAME."
              `(defclass ,a (,name) ()))
            direct-children)))
 
+;; This macro and the following function are related to JSON serialization; see
+;; the below “JSON serialization” section for other related functions.
 (defmacro define-yason-encode-slots (class)
   "Define a YASON:ENCODE-SLOTS method for a CLASS, which simply encodes all of
 CLASS’es slots with JSON keys based on the camel-cased slot name."
   (append
    `(defmethod yason:encode-slots progn ((obj ,class)))
    (mapcar (yason-encode-slot-function)
-           (class-slots-to-camel-cased-strings-alist class))))
+           (class-slots-activity-alist class))))
 
 (defun yason-encode-slot-function ()
   "Helper-function for the DEFINE-YASON-ENCODE-SLOTS macro.
 This returns a function to create a quoted function that should be called for each slot,
 again and again, by YASON:ENCODE-SLOTS."
   (lambda (slot-key-pair)
-    `(let ((value (slot-value obj ',(car slot-key-pair))))
+    `(let ((key ',(car slot-key-pair))
-       (cond ((eq ',(car slot-key-pair) '@context)
+           (value (slot-value obj ',(car slot-key-pair))))
+       (cond ((eq key '@context) ; Encoded in YASON:ENCODE-OBJECT using *@context*
               (setq *@context* (merge-@contexts *@context* value)))
+             ((eq key 'type)     ; Encode type based on class-name or TYPE slot
+              (yason:encode-object-element
+               "type" (or value
+                          (class-pretty-name (class-of obj)))))
              (value
               (yason:encode-object-element ,(cdr slot-key-pair) value))))))
 
@@ -270,28 +278,33 @@ into one. Otherwise, parse it into an associative list."
 
 ;;; JSON serialization
 ;;; ————————————————————————————————————————
+;; Note-worthy: See the above-defined DEFINE-YASON-ENCODE-SLOTS.
 (defmethod yason:encode ((obj object) &optional (stream *standard-output*))
-  (yason:with-object ()
+  (yason:encode-object obj))
-    (if *@context* ; If this object is nested in another, use old context.
-        (yason:encode-object obj)
-        (let ((*@context* (slot-value obj '@context))) ; Unnested, so create context.
-          (yason:encode-object obj)
-          (yason:encode-object-element
-           "@context"
-           *@context*)))
-    (yason:encode-object-element
-     "type"
-     (or (object-type obj)
-         (class-pretty-name (class-of obj))))))
 
-(defun class-slots-to-camel-cased-strings-alist (class)
+(defmethod yason:encode-object ((obj object))
-  "Return an associative list of a CLASS’es direct slots (by symbol) matched with
+  (typecase *@context*
-their names in camel-case format."
+    (null ; If this is the top-level (non-nested) object, establish a @context.
-  (mapcar
+     (let ((*@context* 'top-level))
-   (lambda (slot)
+       (yason:encode-object obj)))
-     (let ((name (closer-mop:slot-definition-name slot)))
+    (symbol ; In the top-level, encode slots and then @context.
-      (cons name (camel-case (symbol-name name)))))
+     (setq *@context* (slot-value obj '@context))
-   (closer-mop:class-direct-slots class)))
+     (yason:with-object ()
+       (yason:encode-slots obj)
+       (yason:encode-object-element "@context" *@context*)))
+    (T ; In nested objects, only encode slots — not *@context*.
+     (yason:with-object ()
+       (yason:encode-slots obj)))))
+
+(defun class-slots-activity-alist (class)
+  "Return an associative list containing CLASSes slots’ symbols consed with
+their sanitized string keys appropriate for ActivityVocabular custom.
+A class with slots MAP-AWAY and COLLECTION-AGAIN would return
+  ((MAP-AWAY . “mapAway”)(COLLECTION-AGAIN . “collectionAgain”))"
+;;  (alist-remove-keys
+;;   'type
+   (alist-mapcdr #'camel-case
+                 (class-slots-alist class)))
 
 (defun merge-@contexts (a b)
   "Given two @context lists, A and B, merge them into one JSON-LD @context list
@@ -343,11 +356,37 @@ items in each will be contained in the resultant list."
   (mapcar (lambda (sym) (find-class sym))
           (find-registered-symbols str)))
 
+(defun alist-remove-keys (item alist &optional (test #'equal))
+  "Remove cells from an associative list whose key TESTs as ITEM."
+  (cl:remove item alist
+             :test (lambda (a cell)
+                     (funcall test a (car cell)))))
+
+(defun alist-mapcdr (function alist)
+  "Apply a FUNCTION to all values (cdrs) of an ALIST’s pairs. Returns a new ALIST
+of the same keys, whose values are the results of FUNCTION."
+  (mapcar
+   (lambda (cell)
+     (cons (car cell)
+           (funcall function (cdr cell))))
+   alist))
+
+(defun class-slots-alist (class)
+  "Return an associative list of a CLASS’es direct slots (by symbol) matched with
+their names as strings. For instance, a class with slots MAP-AWAY and
+COLLECTION-AGAIN would return:
+  ((MAP-AWAY . “MAP-AWAY”)(COLLECTION-AGAIN . “COLLECTION-AGAIN”)"
+  (mapcar
+   (lambda (slot)
+     (let ((name (closer-mop:slot-definition-name slot)))
+      (cons name (symbol-name name))))
+   (closer-mop:class-direct-slots class)))
+
 
 
 ;;; Defining YASON:ENCODE-SLOTS
 ;;; ————————————————————————————————————————
-;; On-the-fly define YASON:ENCODE for each of our distinct AP classes.
+;; On-the-fly define YASON:ENCODE-SLOTS for each of our distinct AP classes.
 (mapcar (lambda (class)
           (closer-mop:finalize-inheritance class)
           (eval `(define-yason-encode-slots ,class)))

t/signatures.lisp

@@ -1,6 +1,6 @@
 ;;;; activitypub-servist/tests/signatures: Testing activitypub-servist/signatures.
 
-;; Copyright © 2023-2024 Jaidyn Levesque <jadedctrl@posteo.at>
+;; Copyright © 2024 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