Functional parsing of JSON nodes into CLOS objects

The class hierarchy should be tweaked a bit; and
the activity-vocabulary class definitions need to
be updated to use the new framework — but it’s
functional!
This commit is contained in:
Jaidyn Ann 2024-08-19 22:43:40 -05:00
parent 14f2f8f4da
commit 6fab9f42d3

View File

@ -27,25 +27,39 @@
;;; Globals ;;; Globals
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defvar *http-cache* (make-hash-table :test #'equal)) (defvar *http-cache* (make-hash-table :test #'equal))
(defvar *json-types* ()) (defvar *json-types* (make-hash-table :test #'equal))
;;; Base class ;;; Base class
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defclass json-ld-type () (defclass json-ld-type ()
((@context :initform "https://www.w3.org/ns/activitystreams"))) ((@context
:initform nil
:documentation
"Used as an override for a classes @context during encoding.
The method JSON-LD-CONTEXT is how the contents of encoded @context is
determined; to change a classes default/calculated @context, override that
method. This slot is for changing a specific objects @context.")
(etc
:initform nil
:documentation
"Components of the JSON object which, during parsing, did not match any specific
slot. This is often filled up in the case of undefined node-types or non-adherent
object definitions.")))
(defgeneric json-ld-context (obj) (defgeneric json-ld-context (obj)
(:documentation (:documentation
"Returns a JSON-LD CLOS objects @context, for use in JSON-encoding of the "Returns a JSON-LD CLOS objects @context, for use in JSON-encoding of the
object. object.
The implementation for the JSON-LD-TYPE class simply returns the @context slots The implementation for the JSON-LD-TYPE class simply returns the activitystreams
value. If you would like to have more a more elaborate logic to @context, you URL.
should override this method.")) If you would like to change @context on a class-level, override this method.
If you would like to change it on an object-level, set the @CONTEXT slot."))
(defmethod json-ld-context ((obj json-ld-type)) (defmethod json-ld-context ((obj json-ld-type))
(slot-value obj '@context)) (or (slot-value obj '@context)
"https://www.w3.org/ns/activitystreams"))
(defmethod yason:encode-slots progn ((obj json-ld-type)) (defmethod yason:encode-slots progn ((obj json-ld-type))
(yason:encode-object-element "@context" (json-ld-context obj))) (yason:encode-object-element "@context" (json-ld-context obj)))
@ -106,10 +120,13 @@ Here is a brief example partially defining the “Place” type from ActivityStr
(longitude longitude (longitude longitude
:required T :required T
:documentation The longitude of a place.)))" :documentation The longitude of a place.)))"
`(progn `(let ((json-class
(define-json-clos-class ,names ,(or direct-superclasses '(json-ld-type)) (define-json-clos-class ,names
,direct-slots ,options) ,(or direct-superclasses `(json-ld-type))
(define-json-type-encoder ,(car names) ,direct-slots))) ,direct-slots ,options)))
(define-json-type-encoder ,(car names) ,direct-slots)
(register-json-type ',names ',direct-slots ,context)
json-class))
(defmacro define-json-clos-class (names direct-superclasses direct-slots options) (defmacro define-json-clos-class (names direct-superclasses direct-slots options)
"Helper-macro for DEFINE-JSON-TYPE. "Helper-macro for DEFINE-JSON-TYPE.
@ -171,39 +188,114 @@ CLASS is the class-name; see DEFINE-JSON-TYPEs docstring about DIRECT-SLOTS."
;;; Parsing ;;; Parsing
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defun register-json-type (names direct-slots context)
"Register a JSON node-type. This allows PARSE to recognize the type (and
corresponding CLOS class) of a node."
(let* ((ctx (parse-context context))
(type-iri (getf (gethash (cadr names) ctx) :id))
(type-name (or type-iri (cadr names))))
(setf (gethash type-name *json-types*)
(json-type-registry-list names ctx direct-slots))))
(defun json-type-registry-list (names parsed-context direct-slots)
"Return a REGISTER-JSON-TYPE-formed registry entry, a simple list of the form:
(TYPE-IRI (PROPERTY-NAME SLOT-NAME) (PROPERTY-NAME SLOT-NAME))
where TYPE-IRI is the (hopefully) fully-resolved IRI form of the node-types
name, though it might be unresolved if context was unprovided or lacking."
(append (list (cons (car names) (cadr names)))
(mapcar
(lambda (slot)
(when (cadr slot)
(let* ((property-name (cadr slot))
(slot-name (car slot))
(ctx-item (gethash property-name parsed-context))
(url (or (getf ctx-item :id)
property-name)))
(cons url (cons slot-name property-name)))))
direct-slots)))
(defun parse (str) (defun parse (str)
"Parse the JSON-LD document contained in STR." "Parse the JSON-LD document contained in STR."
(let ((ctx (make-hash-table :test #'equal)) (let ((ctx (make-hash-table :test #'equal)) ; Parsed context: IRI→name,etc.
(rev-ctx (make-hash-table :test #'equal)) ; Inversed ctx: name→IRI
(parsed (yason:parse str))) (parsed (yason:parse str)))
(values (parse-item parsed ctx) (values (parse-item parsed ctx rev-ctx)
ctx))) ctx)))
(defun parse-item (item &optional ctx) (defun parse-item (item &optional ctx rev-ctx)
"Parse an individual ITEM of a YASON-decoded JSON-LD document." "Parse an individual ITEM of a YASON-decoded JSON-LD document."
(typecase item (typecase item
(hash-table (parse-object item ctx)) (hash-table (parse-table item ctx rev-ctx))
(list (mapcar (lambda (a) (parse-item a ctx)) item)) (list (mapcar (lambda (a) (parse-item a ctx)) item))
(T item))) (T item)))
(defun parse-object (table &optional ctx) (defun parse-table (table &optional ctx rev-ctx)
"Parse a JSON “node object” (as decoded by YASON into a hash-TABLE." "Parse a JSON “node object” (as decoded by YASON into a hash-TABLE."
(let ((ctx (parse-context (gethash "@context" table) ctx))) (let ((ctx (parse-context (gethash "@context" table) ctx)))
;; Update our inverted context-table, so we can resolve property-names→IRIs.
(when (not (eq (hash-table-count rev-ctx)
(hash-table-count ctx)))
(copy-hash-table-to ctx rev-ctx)
(invert-hash-table rev-ctx (lambda (val)
(getf val :id))))
;; Now, actually parse.
(let* ((parsed-table (parse-table-inplace table ctx))
(type (identify-json-type table ctx rev-ctx))
(typedef (gethash type *json-types*)))
(if typedef
(parse-table-into-object parsed-table typedef ctx rev-ctx) ; We prefer this!
parsed-table)))) ; … but just in case you wanna use an undefined type…
(defun parse-table-inplace (table ctx)
"Expand a YASON-parsed JSON-LD node-object in TABLE. That is, replace all
property-names (like, say, duration) with their uncompacted-IRI forms
(like https://www.w3.org/ns/activitystreams#duration).
CTX should be the parsed-context corresponding to the table."
(maphash
(lambda (old-key val)
(let* ((key-ctx (gethash old-key ctx))
(key-iri (getf key-ctx :id))
(key-type (getf key-ctx :type))
(new-key (or key-iri old-key)))
(when key-ctx
(if (not (equal old-key new-key))
(remhash old-key table))
(setf (gethash new-key table)
(parse-item
val
(or (and (hash-table-p val) (alexandria:copy-hash-table ctx))
ctx))))))
table)
table)
(defun parse-table-into-object (table type-def ctx rev-ctx)
"Parse an expanded-form JSON-LD object (TABLE) into a CLOS object.
TYPE-DEF is a type-definition list of the form found in *JSON-TYPES* and made
by REGISTER-JSON-TYPE.
CTX is the according parsed-context, and REV-CTX is the reversed
(IRI property-name) context."
(let ((obj (make-instance (caar type-def))))
(maphash (maphash
(lambda (old-key val) (lambda (property value)
(let* ((key-ctx (gethash old-key ctx)) (let* ((property-def (assoc property type-def :test #'equal))
(key-iri (getf key-ctx :id)) (slot-name (second property-def))
(key-type (getf key-ctx :type)) (etc-value (slot-value obj 'etc)))
(new-key (or key-iri old-key))) (if property-def
(when key-ctx (setf (slot-value obj slot-name) value)
(if (not (equal old-key new-key)) (setf (slot-value obj 'etc)
(remhash old-key table)) (append etc-value
(setf (gethash new-key table) (list (cons property value)))))))
(parse-item
val
(or (and (hash-table-p val) (alexandria:copy-hash-table ctx))
ctx))))))
table) table)
table)) (setf (slot-value obj '@context) (gethash "@context" table))
obj))
(defun identify-json-type (table ctx rev-ctx)
"Given an parsed JSON-LD objects hash-TABLE, return the name/IRI of the
JSON-type that best suits the object using the types registered into
*JSON-TYPES* with REGISTER-JSON-TYPE."
(let* ((type (gethash "@type" table)))
(or (getf (gethash type ctx) :id)
type)))
@ -247,7 +339,7 @@ yet been parsed into CTX."
(typecase item (typecase item
(string (parse-remote-context ctx item)) (string (parse-remote-context ctx item))
(hash-table (parse-context-map ctx item)) (hash-table (parse-context-map ctx item))
(:otherwise nil))) (T nil)))
(defun parse-remote-context (ctx uri) (defun parse-remote-context (ctx uri)
"Parse a remote JSON-LD context at URI, adding its terms to the CTX "Parse a remote JSON-LD context at URI, adding its terms to the CTX
@ -380,3 +472,47 @@ returned."
(defun http-get (uri &key headers) (defun http-get (uri &key headers)
"Makes a GET request to URI, returning the resultant string." "Makes a GET request to URI, returning the resultant string."
(dexador:get uri :headers headers :force-string 't)) (dexador:get uri :headers headers :force-string 't))
(defun invert-hash-table (table &optional tf)
"Return a copy of TABLE with the keys and values inverted.
All values are the new keys for the old keys, and all old keys are
wait, Im getting confused now. Oh, whatever, you know whats up!
Optionally, a TF function can be provided, which will be executed
with the new key as its parameter, and whose return-value will be
the key. Useful for sanitization!"
(let ((new-table (alexandria:copy-hash-table table)))
(maphash (lambda (old-key old-val)
(let ((new-key (if tf (funcall tf old-val) old-val)))
(remhash old-key new-table)
(setf (gethash new-key new-table) old-key)))
new-table)
new-table))
(defun copy-hash-table-to (from to &optional (clobber nil))
"Shallowly copies the keys+values of hash-table FROM into TO.
If CLOBBER is set, old-values in TO will be overwritten."
(maphash (lambda (key val)
(let ((in-to (gethash key to)))
(when (or (and clobber in-to)
(not in-to))
(setf (gethash key to) val))))
from)
to)
(defun plist-keys (plist)
"Return a list of keys in a property list."
(remove-if #'not
(loop for item in plist
for i from 0
collect (when (evenp i) item))))
(defun merge-plists (a b)
"Merge two property lists, favouring adding all properties of A to B not
pre-existing in B."
(let ((a-keys (plist-keys a))
(b-keys (plist-keys b)))
(loop for key in a-keys
do (when (not (find key b-keys))
(setf (getf b key) (getf a key))))
b))