Fix serializing @context & type in nested objects

This commit is contained in:
Jaidyn Ann 2024-06-21 18:15:47 -05:00
parent 299a529151
commit ddc3add769
2 changed files with 64 additions and 25 deletions

View File

@ -36,6 +36,7 @@
:tentative-accept :tentative-reject :tombstone :travel :undo :update :video :tentative-accept :tentative-reject :tombstone :travel :undo :update :video
:view :view
;; Slots ;; Slots
:@context :type
:activity-actor :activity-instrument :activity-object :activity-origin :activity-actor :activity-instrument :activity-object :activity-origin
:activity-result :activity-target :activity-result :activity-target
:collection-current :collection-first :collection-items :collection-last :collection-current :collection-first :collection-items :collection-last
@ -112,22 +113,29 @@ of NAME."
`(defclass ,a (,name) ())) `(defclass ,a (,name) ()))
direct-children))) 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) (defmacro define-yason-encode-slots (class)
"Define a YASON:ENCODE-SLOTS method for a CLASS, which simply encodes all of "Define a YASON:ENCODE-SLOTS method for a CLASS, which simply encodes all of
CLASSes slots with JSON keys based on the camel-cased slot name." CLASSes slots with JSON keys based on the camel-cased slot name."
(append (append
`(defmethod yason:encode-slots progn ((obj ,class))) `(defmethod yason:encode-slots progn ((obj ,class)))
(mapcar (yason-encode-slot-function) (mapcar (yason-encode-slot-function)
(class-slots-to-camel-cased-strings-alist class)))) (class-slots-activity-alist class))))
(defun yason-encode-slot-function () (defun yason-encode-slot-function ()
"Helper-function for the DEFINE-YASON-ENCODE-SLOTS macro. "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, This returns a function to create a quoted function that should be called for each slot,
again and again, by YASON:ENCODE-SLOTS." again and again, by YASON:ENCODE-SLOTS."
(lambda (slot-key-pair) (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))) (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 (value
(yason:encode-object-element ,(cdr slot-key-pair) 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 ;;; JSON serialization
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
;; Note-worthy: See the above-defined DEFINE-YASON-ENCODE-SLOTS.
(defmethod yason:encode ((obj object) &optional (stream *standard-output*)) (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 CLASSes 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) (defun merge-@contexts (a b)
"Given two @context lists, A and B, merge them into one JSON-LD @context list "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)) (mapcar (lambda (sym) (find-class sym))
(find-registered-symbols str))) (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 ALISTs 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 CLASSes 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 ;;; 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) (mapcar (lambda (class)
(closer-mop:finalize-inheritance class) (closer-mop:finalize-inheritance class)
(eval `(define-yason-encode-slots ,class))) (eval `(define-yason-encode-slots ,class)))

View File

@ -1,6 +1,6 @@
;;;; activitypub-servist/tests/signatures: Testing activitypub-servist/signatures. ;;;; 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 ;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU Affero General Public License ;; modify it under the terms of the GNU Affero General Public License