From 7be6b396ee676fc18911f5ed01bf97bc42140df9 Mon Sep 17 00:00:00 2001 From: Jaidyn Ann <10477760+JadedCtrl@users.noreply.github.com> Date: Fri, 16 Aug 2024 22:33:40 -0500 Subject: [PATCH] Begin CLOS-based system for JSON-LD encoding/etc MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit So far, defining a JSON-LD node-type automagically defines a CLOS class and a YASON-encoder; what remains is the decoder. … and also @context-propagation in the encoder. --- src/json-ld.lisp | 122 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 121 insertions(+), 1 deletion(-) diff --git a/src/json-ld.lisp b/src/json-ld.lisp index e5207d0..d1055f1 100644 --- a/src/json-ld.lisp +++ b/src/json-ld.lisp @@ -17,7 +17,9 @@ (defpackage #:activity-servist/json-ld (:use #:cl) - (:nicknames "AS/JSON-LD" "JSON-LD")) + (:nicknames "AS/JSON-LD" "JSON-LD") + (:export + #:define-json-class)) (in-package #:activity-servist/json-ld) @@ -25,6 +27,124 @@ ;;; Globals ;;; ———————————————————————————————————————— (defvar *http-cache* (make-hash-table :test #'equal)) +(defvar *json-types* ()) + +(defclass json-ld-type () + ((@context :initform "https://www.w3.org/ns/activitystreams"))) + +(defmethod json-ld-context ((obj json-ld-type)) + (slot-value obj '@context)) + +(defmethod yason:encode-slots progn ((obj json-ld-type)) + (yason:encode-object-element "@context" (json-ld-context obj))) + +(defmacro define-json-class (names direct-superclasses context direct-slots &rest options) + "Used to define a CLOS class and a JSON encoder/decoder for a JSON-LD node-type. +An instance of class will be output, instead of a hash-table, when parsing JSON-LD +with JSON-LD:PARSE. Instances of this class can be encoded into JSON with YASON:ENCODE. + +NAMES is a pair with two values: The CLOS class-name, and the name used during +encoding as @type’s value. If only the CLOS class-name is provided, @type will +not be encoded for this object. + +DIRECT-SUPERCLASSES is a list of JSON-LD CLOS classes, whose slots and context +this should inherit. JSON-LD-TYPE should be somewhere in the hierarchy, in order +to provide “@context”; if no superclasses are provided, JSON-LD-TYPE is default. + +CONTEXT is a context hash-table, parsed from a JSON-LD context by JSON-LD:PARSE +or JSON-LD:PARSE-CONTEXT. Any terms defined in this context will be used to +resolve names in your class definition — including the class-name and slot-names. + +DIRECT-SLOTS is a list of slots of the format: + (SLOT-NAME PROPERTY-NAME SLOT-OPTION … SLOT-OPTION) + +Where SLOT-NAME is the symbol corresponding to the slot and PROPERTY-NAME is the +name used in JSON parsing/encoding. Slots without a PROPERY-NAME will not be +encoded nor decoded in JSON. + +SLOT-OPTIONS are key/value pairs in the format of DEFCLASS’es slot-options. +Keywords such as :INITFORM, :DOCUMENTATION, etc. can be used. +There are two keywords with behavior unlike DEFCLASS, however: +:REQUIRED and :ACCESSOR. + +By default, a slot will have an init-form of NIL; this can of course be +overridden by putting :INITFORM yourself in the slot definition. +Set :REQUIRED to T to not set :INITFORM at all, effectively making the slot +“required.” + +By default, a slot will have an accessor named after the class and slot, like +PLACE-RADIUS for the class PLACE and the slot RADIUS. +Set :ACCESSOR to NIL to define no accessor at all. + +OPTIONS contains ordinary class options, in the format of DEFCLASS; for +instance, :DOCUMENTATION. + +Here is a brief example partially defining the “Place” type from ActivityStreams: + + (define-json-type (place “Place”) (object) ctx + ((altitude “altitude” + :documentation “Indicates the altitude of a place.”) + (latitude “latitude” + :required T + :documentation “The latitude of a place.”) + (longitude “longitude” + :required T + :documentation “The longitude of a place.”)))" + `(progn + (define-json-clos-class ,names ,(or direct-superclasses '(json-ld-type)) ,context ,direct-slots ,options) + (define-json-class-encoder ,(car names) ,direct-slots))) + +(defmacro define-json-clos-class (names direct-superclasses context direct-slots options) + "Helper-macro for DEFINE-JSON-CLASS. +This actually defines the CLOS class for a JSON-LD node-type. +See DEFINE-JSON-CLASS’s docstring for a description of parameters." + (append `(defclass ,(car names) ,direct-superclasses + ,(mapcar (lambda (slot) + (let* ((our-slot-opts + (cddr slot)) + (slot-opts + (json-type-slot-options (car names) (car slot) + our-slot-opts))) + (append (list (car slot)) + slot-opts))) + direct-slots)) + options)) + +(defmacro define-json-class-encoder (class direct-slots) + "Helper-macro for DEFINE-JSON-CLOS-CLASS. +This actually defines the YASON-encoder for a JSON-LD node-type. +CLASS is the class-name; see DEFINE-JSON-CLASS’s docstring about DIRECT-SLOTS." + (append + `(defmethod yason:encode-slots progn ((obj ,class))) + (mapcar (lambda (slot) + `(yason:encode-object-element ,(cadr slot) (slot-value obj ',(car slot)))) + direct-slots))) + +(defun json-type-slot-options (class-name slot-name slot-opts) + "Return DEFCLASS-format slot options from DEFINE-JSON-CLASS-format SLOT-OPTS, +applying default slot-options, etc." + (json-type-normalize-slot-options + (merge-plists (json-type-implicit-slot-options class-name slot-name) + slot-opts))) + +(defun json-type-implicit-slot-options (class-name slot-name) + "Return default property-list slot options for a JSON-type CLOS class." + (list :initform nil + :accessor (intern (format nil "~A-~A" class-name slot-name)))) + +(defun json-type-normalize-slot-options (slot-opts) + "Take property-list slot options from a DEFINE-JSON-CLASS format and massage it +into a DEFCLASS format." + (let* ((required (getf slot-opts :required)) + (sans-required (alexandria:remove-from-plist slot-opts :required)) + (sans-initform-maybe (if required + (alexandria:remove-from-plist sans-required :initform) + sans-required)) + (sans-accessor-maybe (if (and (find :accessor slot-opts) + (not (getf slot-opts :accessor))) + (alexandria:remove-from-plist sans-initform-maybe :accessor) + sans-initform-maybe))) + sans-accessor-maybe))