jadedctrl/activity-servist
jadedctrl/ activity-servist
1
0
Disbranĉigi 0
Fontkodo Issues Tirpetoj Activity

Make sure to encode @TYPE whenever applicable 

This fixes @TYPE not getting encoded into JSON
when “@type” is aliased and not set directly in
the object, but rather in the class itself.
This commit is contained in:
Jaidyn Ann 2024-12-30 18:19:21 -06:00
parent e80661415c
commit ad6c879f55
1 changed files with 37 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/json-ld.lisp
View File

@ -108,25 +108,39 @@ If you would like to change it on an object-level, set the @CONTEXT slot."))
(flatten-contained-contexts obj) (flatten-contained-contexts obj)
;; We only want to encode @context, @id, and @type if the child class doesn’t ;; We only want to encode @context, @id, and @type if the child class doesn’t
;; have its own alias for them. ;; have its own alias for them.
(flet ((aliased-prop-p (property-name type-def) (labels ((property-alias (property-name type-def)
"Return either PROPERTY-NAME or its alias. I.E., “@type” → “type”."
(cddr (assoc property-name type-def :test #'equal)))
(aliased-prop-p (property-name type-def)
"Return whether or not PROPERTY-NAME is aliased."
(not (equal property-name (not (equal property-name
(cddr (assoc property-name type-def :test #'equal)))))) (property-alias property-name type-def)))))
(let* ((class-name (class-name (class-of obj))) (let* ((class-name (class-name (class-of obj)))
(type-def (cdr (class-json-type-definition class-name))) (type-def-w-name (class-json-type-definition class-name))
;; (@context is a special case; we should usually encode it.) (type-def (cdr type-def-w-name))
(no-context-p (and (aliased-prop-p "@context" type-def) (don’t-context-p (and (aliased-prop-p "@context" type-def)
(slot-value obj '@context))) (slot-value obj '@context)))
(no-id-p (aliased-prop-p "@id" type-def)) (object-context (@context obj))
(no-type-p (aliased-prop-p "@type" type-def)) (object-id (and (slot-boundp obj '@id) (@id obj)))
(context (@context obj)) (object-type (and (slot-boundp obj '@type) (@type obj)))
(id (and (slot-boundp obj '@id) (@id obj))) (class-type (cdar type-def-w-name)))
(type (and (slot-boundp obj '@type) (@type obj)))) ;; Encode @CONTEXT unless it’s done by DEFINE-JSON-TYPE-ENCODER’s encoder,
(when (and context (not no-context-p)) ;; which only happens when “@context” is aliased & set at the object-level
(yason:encode-object-element "@context" context)) ;; (that is, the slot’s set and we don’t defer to the class).
(when (and id (not no-id-p)) (when (and object-context (not don’t-context-p))
(yason:encode-object-element "@id" id)) (yason:encode-object-element "@context" object-context))
(when (and type (not no-type-p)) ;; Encode @ID unless it’s done by DEFINE-JSON-TYPE-ENCODER’s encoder,
(yason:encode-object-element "@type" type)))) ;; which is in the case of an alias.
(when (and object-id (not (aliased-prop-p "@id" type-def)))
(yason:encode-object-element "@id" object-id))
;; Encode @TYPE unless it’s done by DEFINE-JSON-TYPE-ENCODER’s encoder,
;; which only happens when “@type” is aliased & set at the object-level.
(cond ((and object-type (not (aliased-prop-p "@type" type-def)))
(yason:encode-object-element "@type" object-type))
((and class-type (not object-type))
(yason:encode-object-element (property-alias "@type" type-def)
class-type)))))
;; Now encode all properties that don’t have dedicated slots, those in @ETC.
(mapcar (lambda (alist-cell) (mapcar (lambda (alist-cell)
(yason:encode-object-element (car alist-cell) (yason:encode-object-element (car alist-cell)
(cdr alist-cell))) (cdr alist-cell)))
@ -224,11 +238,10 @@ applying default slot-options, etc."
(defun json-type-normalize-slot-options (slot-opts) (defun json-type-normalize-slot-options (slot-opts)
"Take property-list slot options from a DEFINE-JSON-TYPE format and massage it "Take property-list slot options from a DEFINE-JSON-TYPE format and massage it
into a DEFCLASS format." into a DEFCLASS format."
(let* ((sans-accessor-maybe (if (and (find :accessor slot-opts) (if (and (find :accessor slot-opts)
(not (getf slot-opts :accessor))) (not (getf slot-opts :accessor)))
(alexandria:remove-from-plist slot-opts :accessor) (alexandria:remove-from-plist slot-opts :accessor)
slot-opts))) slot-opts))
sans-accessor-maybe))