Merge @contexts of nested JSON-LD objects
This commit is contained in:
parent
a12e02c51b
commit
780951faaa
|
@ -55,6 +55,17 @@
|
||||||
|
|
||||||
(in-package #:activitypub-servist/activity-vocabulary)
|
(in-package #:activitypub-servist/activity-vocabulary)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; Globals
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
;; 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 (LET), and should never be
|
||||||
|
;; modified globally (as we expect it to be nil in top-level objects).
|
||||||
|
(defparameter *@context* nil)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Macros
|
;;; Macros
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
|
@ -95,17 +106,25 @@ of NAME."
|
||||||
`(defclass ,a (,name) ()))
|
`(defclass ,a (,name) ()))
|
||||||
direct-children)))
|
direct-children)))
|
||||||
|
|
||||||
(defmacro define-yason-encode-slots-to-camel-cased-keys (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
|
||||||
CLASS’es slots with JSON keys based on the camel-cased slot name."
|
CLASS’es 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 (lambda (slot-key-pair)
|
(mapcar (yason-encode-slot-function)
|
||||||
`(let ((value (slot-value obj ',(car slot-key-pair))))
|
|
||||||
(when value
|
|
||||||
(yason:encode-object-element ,(cdr slot-key-pair) value))))
|
|
||||||
(class-slots-to-camel-cased-strings-alist class))))
|
(class-slots-to-camel-cased-strings-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))))
|
||||||
|
(cond ((eq ',(car slot-key-pair) '@context)
|
||||||
|
(setq *@context* (merge-@contexts *@context* value)))
|
||||||
|
(value
|
||||||
|
(yason:encode-object-element ,(cdr slot-key-pair) value))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Core types
|
;;; Core types
|
||||||
|
@ -202,39 +221,9 @@ CLASS’es slots with JSON keys based on the camel-cased slot name."
|
||||||
(mention))
|
(mention))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; JSON serialization
|
|
||||||
;;; ————————————————————————————————————————
|
|
||||||
(defmethod yason:encode ((obj object) &optional (stream *standard-output*))
|
|
||||||
(yason:with-output (stream)
|
|
||||||
(yason:with-object ()
|
|
||||||
(yason:encode-object obj)
|
|
||||||
(yason:encode-object-element
|
|
||||||
"type"
|
|
||||||
(or (object-type obj)
|
|
||||||
(class-pretty-name (class-of obj)))))))
|
|
||||||
|
|
||||||
;; Ensure all classes have their slots’ encodings defined with YASON.
|
|
||||||
(mapcar (lambda (class)
|
|
||||||
(closer-mop:finalize-inheritance class)
|
|
||||||
(eval `(define-yason-encode-slots-to-camel-cased-keys ,class)))
|
|
||||||
(mapcar #'find-class
|
|
||||||
'(object link activity collection collection-page
|
|
||||||
ordered-collection-page place profile relationship tombstone)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Util
|
;;; Util
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
(defun class-slots-to-camel-cased-strings-alist (class)
|
|
||||||
"Return an associative list of a CLASS’es direct slots (by symbol) matched with
|
|
||||||
their names in camel-case format."
|
|
||||||
(mapcar
|
|
||||||
(lambda (slot)
|
|
||||||
(let ((name (closer-mop:slot-definition-name slot)))
|
|
||||||
(cons name (camel-case (symbol-name name)))))
|
|
||||||
(closer-mop:class-direct-slots class)))
|
|
||||||
|
|
||||||
(defun camel-case (string)
|
(defun camel-case (string)
|
||||||
"Convert a STRING to camel-casing.
|
"Convert a STRING to camel-casing.
|
||||||
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
|
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
|
||||||
|
@ -249,3 +238,58 @@ to us) removed."
|
||||||
(defun class-pretty-name (class)
|
(defun class-pretty-name (class)
|
||||||
"Return a CLASS’es name in a “pretty” (sentence-capitalized) string."
|
"Return a CLASS’es name in a “pretty” (sentence-capitalized) string."
|
||||||
(string-capitalize (symbol-name (class-name class))))
|
(string-capitalize (symbol-name (class-name class))))
|
||||||
|
|
||||||
|
(defun merge-lists (a b)
|
||||||
|
"Given lists A and B, merge them into one list non-redundantly — all unique
|
||||||
|
items in each will be contained in the resultant list."
|
||||||
|
(append a (remove-if (lambda (item) (find item a :test #'equal)) b)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; JSON serialization
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
(defmethod yason:encode ((obj object) &optional (stream *standard-output*))
|
||||||
|
(yason:with-output (stream)
|
||||||
|
(yason:with-object ()
|
||||||
|
(if *@context*
|
||||||
|
(yason:encode-object obj)
|
||||||
|
(let ((*@context* (slot-value obj '@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)
|
||||||
|
"Return an associative list of a CLASS’es direct slots (by symbol) matched with
|
||||||
|
their names in camel-case format."
|
||||||
|
(mapcar
|
||||||
|
(lambda (slot)
|
||||||
|
(let ((name (closer-mop:slot-definition-name slot)))
|
||||||
|
(cons name (camel-case (symbol-name name)))))
|
||||||
|
(closer-mop:class-direct-slots class)))
|
||||||
|
|
||||||
|
(defun merge-@contexts (a b)
|
||||||
|
"Given two @context lists, A and B, merge them into one JSON-LD @context list
|
||||||
|
containing both of their elements."
|
||||||
|
(cond ((equal a b) a)
|
||||||
|
((not b) a)
|
||||||
|
((not a) b)
|
||||||
|
((and (listp a)
|
||||||
|
(find b a :test #'equal))
|
||||||
|
a)
|
||||||
|
(T
|
||||||
|
(merge-lists
|
||||||
|
(if (listp a) a (list a))
|
||||||
|
(if (listp b) b (list b))))))
|
||||||
|
|
||||||
|
;; Ensure all classes have their slots’ encodings defined with YASON.
|
||||||
|
(mapcar (lambda (class)
|
||||||
|
(closer-mop:finalize-inheritance class)
|
||||||
|
(eval `(define-yason-encode-slots ,class)))
|
||||||
|
(mapcar #'find-class
|
||||||
|
'(object link activity collection collection-page
|
||||||
|
ordered-collection-page place profile relationship tombstone)))
|
||||||
|
|
Ŝarĝante…
Reference in New Issue