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

Compare commits

base: jadedctrl:6fab9f42d32f895e7560a6b0153b5ea220f990a0
Branches Etikedoj
jadedctrl:master
...
compare: jadedctrl:4df575610e3b3a8939feb27d10fb33ca4105b651
Branches Etikedoj
jadedctrl:master

2 Enmetoj
6fab9f42d3 ... 4df575610e

Author SHA1 Message Date
Jaidyn Ann 4df575610e Remove old JSON-LD system; move OBJECT to new one 
Our old JSON-LD encoder/decoder was bad, and not
CLOS. This removes it from activity-streams.lisp,
and replaces its definition of the ActivityStreams
Object type to our new system.
 2024-08-21 18:00:08 -05:00
Jaidyn Ann bae4fbbd13 Fix slot-inheritance during JSON type-registration 
Previously, only direct-slots were registered; now
those of parent classes are also registered to
*JSON-TYPES*.
 2024-08-21 17:59:22 -05:00
2 changed files with 196 additions and 343 deletions
Show Stats Expand all files Collapse all files

394
src/activity-streams.lisp
View File

@ -3,315 +3,129 @@
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at> ;; Copyright © 2024 Jaidyn Ann <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 General Public License as ;; modify it under the terms of the GNU Affero General Public License
;; published by the Free Software Foundation, either version 3 of ;; as published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version. ;; the License, or (at your option) any later version.
;; ;;
;; This program is distributed in the hope that it will be useful, ;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details. ;; GNU Affero General Public License for more details.
;; ;;
;; You should have received a copy of the GNU General Public License ;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>. ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(defpackage #:activity-servist/activity-streams (defpackage #:activity-servist/activity-streams
(:use #:cl) (:use #:cl)
(:nicknames "AS/AS" "ACTIVITY-STREAMS") (:nicknames "AS/AS" "ACTIVITY-STREAMS")
(:export (:export
;; Functions
:parse :encode
:define-class-encoders
;; Globals
:*ap-packages* :*default-class*
;; Classes ;; Classes
:object :object
;; Accessors ;; Accessors
:object-@context :object-unsupported #'object-actor #'object-attachment #'object-attributed-to #'object-audience
#'object-content #'object-context #'object-name #'object-end-time
#'object-generator #'object-icon #'object-image #'object-in-reply-to
#'object-location #'object-preview #'object-published #'object-replies
#'object-start-time #'object-summary #'object-tag #'object-updated
#'object-url #'object-to #'object-bto #'object-cc #'object-bcc
#'object-media-type #'object-duration
;; Slots ;; Slots
:@context :@type :type :@id :id :unsupported)) :attachment :attributed-to :audience :content :context :name :end-time
:generator :icon :image :in-reply-to :location :preview :published :replies
:start-time :summary :tag :updated :url :to :bto :cc :bcc :media-type :duration))
(in-package #:activity-servist/activity-streams) (in-package #:activity-servist/activity-streams)
;;; Globals
;;; ————————————————————————————————————————
(defparameter *ap-packages* (list :activity-servist/activity-vocabulary *package*)
"A list of packages in which we should search for AP classes and slot-symbols
during JSON parsing. The class-name searched for is simply the value of the JSON
object’s “type” key. The package first in the list to export such a symbol
is the winner.")
(defparameter *default-class* 'activity-servist/activity-streams:object
"The class used for ActivityStreams objects found during parsing that don’t
have a corresponding class defined. Notably, all keys and values without
corresponding slots are placed in the UNSUPPORTED slot.
The class you choose should inherit ACTIVITY-SERVIST/ACTIVITY-STREAMS:OBJECT.")
;; Private, internal variable.
(defparameter *@context* nil
"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 during encoding (LET), and should never be
modified globally (as we expect it to be nil in top-level objects.")
;;; Macros
;;; ————————————————————————————————————————
;; 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)
"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."
(append
`(defmethod yason:encode-slots progn ((obj ,class)))
(mapcar (yason-encode-slot-function)
(class-slots-activity-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 ((key ',(car slot-key-pair))
(value (ignore-errors (slot-value obj ',(car slot-key-pair)))))
(cond ((eq key '@context) ; Actually in YASON:ENCODE-OBJECT using *@context*
(setq *@context* (merge-@contexts *@context* (object-@context obj))))
((eq key 'unsupported)
;; Keys/values without a slot are stored in this UNSUPPORTED alist.
(mapcar (lambda (cell)
(yason:encode-object-element
(camel-case (symbol-name (car cell)))
(cdr cell)))
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
(yason:encode-object-element ,(cdr slot-key-pair) value))))))
;;; Core class ;;; Core class
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defclass object () (json-ld::define-json-type (object "Object") () "https://www.w3.org/ns/activitystreams"
((@context :initform nil) ((actor
(as/as:@type :initform nil) "actor"
(as/as:type :initform nil) :documentation "Describes one or more entities that either performed or are expected to perform the activity. Any single activity can have multiple actors. The actor MAY be specified using an indirect Link.")
(as/as:@id :initform nil) (attachment
(as/as:id :initform nil) "attachment"
(as/as:unsupported :initform nil :accessor object-unsupported))) :documentation "Identifies a resource attached or related to an object that potentially requires special handling. The intent is to provide a model that is at least semantically similar to attachments in email.")
(attributed-to
"attributedTo"
:documentation "Identifies one or more entities to which this object is attributed. The attributed entities might not be Actors. For instance, an object might be attributed to the completion of another activity.")
;;; Accessors (audience
;;; ———————————————————————————————————————— "audience"
(defgeneric object-@context (obj) :documentation "Identifies one or more entities that represent the total population of entities for which the object can considered to be relevant.")
(:documentation "Accessor for an object’s associated JSON-LD @context. (content
As @context can sometimes vary on an object’s contents, on-the-fly, this "content"
method is invoked during JSON encoding of an object. The @CONTEXT :documentation "The content or textual representation of the Object encoded as a JSON string. By default, the value of content is HTML. The media-type property can be used in the object to indicate a different content type.
slot-value should be prioritized over the @CONTEXT value is calculated The content MAY be expressed using multiple language-tagged values. ")
by this method.")) (context
"context"
(defmethod object-@context ((obj object)) :documentation "Identifies the context within which the object exists or an activity was performed.
(or (slot-value obj '@context) The notion of “context” used is intentionally vague. The intended function is to serve as a means of grouping objects and activities that share a common originating context or purpose. An example could be all activities relating to a common project or event.")
"https://www.w3.org/ns/activitystreams")) (name
"name"
(defmethod (setf object-@context) (context (obj object)) :documentation "A simple, human-readable, plain-text name for the object. HTML markup MUST NOT be included. The name MAY be expressed using multiple language-tagged values.")
(setf (slot-value obj '@context) context)) (end-time
"endTime"
:documentation "The date and time describing the actual or expected ending time of the object. When used with an Activity object, for instance, the end-time property specifies the moment the activity concluded or is expected to conclude.")
(generator
;;; JSON parsing "generator"
;;; ———————————————————————————————————————— :documentation "Identifies the entity (e.g. an application) that generated the object.")
(defun parse (string) (icon
"Parse a string containing JSON into an ActivityPub object." "icon"
(parse-table (yason:parse string))) :documentation "Indicates an entity that describes an icon for this object. The image should have an aspect ratio of one (horizontal) to one (vertical) and should be suitable for presentation at a small size.")
(image
(defun parse-table (table) "image"
"Parse a hash-table corresponding to YASON-parsed JSON into an ActivityPub object." :documentation "Indicates an entity that describes an image for this object. Unlike the icon property, there are no aspect ratio or display size limitations assumed.")
(let* ((found-class (car (find-registered-classes (param-case (gethash "type" table))))) (in-reply-to
(class (or found-class (find-class *default-class*))) "inReplyTo"
(obj (make-instance class))) :documentation "Indicates one or more entities for which this object is considered a response.")
(loop for key being each hash-key of table (location
for val being each hash-value of table "location"
do (let* ((slot-name (string-upcase (param-case key))) :documentation "Indicates one or more physical or logical locations associated with the object.")
(slot-sym (car (find-registered-symbols slot-name))) (preview
(val (parse-value val))) "preview"
(handler-case :documentation "Identifies an entity that provides a preview of this object.")
(setf (slot-value obj slot-sym) val) (published
(error nil "published"
(setf (slot-value obj 'unsupported) :documentation "The date and time describing the actual or expected starting time of the object. When used with an Activity object, for instance, the start-time property specifies the moment the activity began or is scheduled to begin.")
(append (ignore-errors (slot-value obj 'unsupported)) (replies
(list (cons (intern slot-name) val)))))))) "replies"
obj)) :documentation "Identifies a Collection containing objects considered to be responses to this object.")
(start-time
(defun parse-value (val) "startTime"
"Parse the value of a key found in YASON-parsed JSON. :documentation "The date and time describing the actual or expected starting time of the object. When used with an Activity object, for instance, the start-time property specifies the moment the activity began or is scheduled to begin.")
All ActivityPub objects (hash-tables containing “type”) will be parsed into (summary
ActivityPub objects; all others will parsed into associative lists." "summary"
(typecase val :documentation "A natural language summarization of the object encoded as HTML. Multiple language tagged summaries MAY be provided.")
(hash-table (maybe-parse-table val)) (tag
(list (mapcar (lambda (a) "tag"
(if (hash-table-p a) :documentation "One or more “tags” that have been associated with an objects. A tag can be any kind of Object. The key difference between attachment and tag is that the former implies association by inclusion, while the latter implies associated by reference.")
(maybe-parse-table a) (updated
a)) "updated"
val)) :documentation "The date and time at which the object was updated.")
(t val))) (url
"url"
(defun maybe-parse-table (table) :documentation "Identifies one or more links to representations of the object.")
"If a hash-table seems to be a valid ActivityPub object, attempt parsing it (to
into one. Otherwise, parse it into an associative list." "to"
(if (gethash "type" table) :documentation "Identifies an entity considered to be part of the public primary audience of an Object.")
(parse-table table) (bto
(alexandria:hash-table-alist table))) "bto"
:documentation "Identifies an Object that is part of the private primary audience of this Object.")
(cc
"cc"
;;; JSON serialization :documentation "Identifies an Object that is part of the public secondary audience of this Object.")
;;; ———————————————————————————————————————— (bcc
(defun define-class-encoders (classes) "bcc"
"For each class in CLASSES, define an YASON:ENCODE-SLOTS method for that class, :documentation "Identifies one or more Objects that are part of the private secondary audience of this Object.")
which only encodes slots unique to that class (as ENCODE-SLOTS is called for each (media-type
inherited class). Each slot’s name is converted to camel-case, as per convention." "mediaType"
(mapcar (lambda (class) :documentation "When used on a Link, identifies the MIME media type of the referenced resource.
(closer-mop:finalize-inheritance class) When used on an Object, identifies the MIME media type of the value of the content property. If not specified, the content property is assumed to contain text/html content.")
(eval `(define-yason-encode-slots ,class))) (duration
classes)) "duration"
:documentation "When the object describes a time-bound resource, such as an audio or video, a meeting, etc, the duration property indicates the object's approximate duration. The value MUST be expressed as an xsd:duration as defined by [ xmlschema11-2], section 3.3.6 (e.g. a period of 5 seconds is represented as “PT5S”)."))
(defun encode (obj &optional (stream *standard-output*)) (:documentation
"Encode OBJ into JSON. A mere wrapper around YASON:ENCODE." "Describes an object of any kind. The Object type serves as the base type for
(yason:encode obj stream)) most of the other kinds of objects defined in the Activity Vocabulary,
including other Core types such as Activity, IntransitiveActivity, Collection
(defmethod yason:encode ((obj object) &optional (stream *standard-output*)) and OrderedCollection."))
(yason:with-output (stream)
(yason:encode-object obj)))
(defmethod yason:encode-object ((obj object))
(typecase *@context*
(null ; If this is the top-level (non-nested) object, establish a @context.
(let ((*@context* 'top-level))
(yason:encode-object obj)))
(symbol ; In the top-level, encode slots and then @context.
(setq *@context* (object-@context obj))
(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-mapcdr #'camel-case
(class-slots-alist 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))))))
;;; Util
;;; ————————————————————————————————————————
(defun camel-case (string)
"Convert a STRING to camel-casing. That is, casingLikeThis.
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
character at the start of the string gets erroneously (or at least undesireably,
to us) removed."
(keep-nonalphanumeric-prefix string
(str:camel-case string)))
(defun param-case (string)
"Convert a STRING to param-casing. That is, casing-like-this.
Wrapper around STR:PARAM-CASE, working around a bug that a non-alphanumeric
character at the start of the string gets erroneously (or at least undesireably,
to us) removed."
(keep-nonalphanumeric-prefix string
(str:param-case string)))
(defun camel-case (str)
"Convert a STRING to camel-casing.
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
character at the start of the string gets erroneously (or at least undesireably,
to us) removed."
(keep-nonalphanumeric-prefix str (str:camel-case str)))
(defun keep-nonalphanumeric-prefix (str child-str)
"This ensures that a CHILD-STR derived from STR has the same nonalphanumeric
prefix as STR, as some functions like to remove such prefixes."
(if (not (alphanumericp (aref str 0)))
(concatenate 'string
(string (aref str 0))
child-str)
child-str))
(defun class-pretty-name (class)
"Return a CLASS’es name in a “pretty” (sentence-capitalized) string."
(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)))
(defun find-registered-symbols (str)
"Find all symbols identified by string STR within packages in the
*ap-packages* list."
(remove-if
#'not
(mapcar (lambda (package)
(multiple-value-bind (sym context)
(find-symbol (string-upcase str) package)
(unless (eq context :inherited)
sym)))
*ap-packages*)))
(defun find-registered-classes (str)
"Find all classes identified by string STR within pacakges in the
*ap-packages* list."
(remove-if
#'not
(mapcar (lambda (sym) (find-class sym))
(find-registered-symbols str))))
(defun alist-mapcdr (function alist)
"Apply a FUNCTION to all values (cdrs) of an ALIST’s 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 CLASS’es 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
;;; ————————————————————————————————————————
(as/as:define-class-encoders (list (find-class 'object)))

125
src/json-ld.lisp
View File

@ -19,7 +19,11 @@
(:use #:cl) (:use #:cl)
(:nicknames "AS/JSON-LD" "JSON-LD") (:nicknames "AS/JSON-LD" "JSON-LD")
(:export (:export
#:define-json-type #:json-ld-context)) #:define-json-type
;; Accessors
#:json-ld-context #:json-ld-etc #:json-ld-id #:json-ld-type
;; Slots
:@context :@id :@type :.etc))
(in-package #:activity-servist/json-ld) (in-package #:activity-servist/json-ld)
@ -33,7 +37,7 @@
;;; Base class ;;; Base class
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defclass json-ld-type () (defclass json-ld-object ()
((@context ((@context
:initform nil :initform nil
:documentation :documentation
@ -41,28 +45,57 @@
The method JSON-LD-CONTEXT is how the contents of encoded @context is The method JSON-LD-CONTEXT is how the contents of encoded @context is
determined; to change a class’es default/calculated @context, override that determined; to change a class’es default/calculated @context, override that
method. This slot is for changing a specific object’s @context.") method. This slot is for changing a specific object’s @context.")
(etc (@id
:initform nil :initform nil
:accessor json-ld-id
:documentation
"Provides the globally unique identifier for an object.")
(@type
:initform nil
:accessor json-ld-type
:documentation
"Identifies the type of an object. Used to determine the corresponding CLOS-object.")
(.etc
:initform nil
:accessor json-ld-etc
:documentation :documentation
"Components of the JSON object which, during parsing, did not match any specific "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 slot. This is often filled up in the case of undefined node-types or non-adherent
object definitions."))) object definitions.")))
(setf (gethash "*" *json-types*)
'((json-ld-object)
("@context" @context . "@context")
("@id" @id . "@id")
("@type" @type . "@type")))
(defgeneric json-ld-context (obj) (defgeneric json-ld-context (obj)
(:documentation (:documentation
"Returns a JSON-LD CLOS object’s @context, for use in JSON-encoding of the "Returns a JSON-LD CLOS object’s @context, for use in JSON-encoding of the
object. object.
The implementation for the JSON-LD-TYPE class simply returns the activitystreams The implementation for the JSON-LD-OBJECT class simply returns the activitystreams
URL. URL.
If you would like to change @context on a class-level, 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.")) 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-object))
(or (slot-value obj '@context) (or (slot-value obj '@context)
"https://www.w3.org/ns/activitystreams")) "https://www.w3.org/ns/activitystreams"))
(defmethod yason:encode-slots progn ((obj json-ld-type)) (defmethod yason:encode-slots progn ((obj json-ld-object))
(let ((context (json-ld-context obj))
(id (json-ld-id obj))
(type (json-ld-type obj)))
(when context
(yason:encode-object-element "@context" (json-ld-context obj))) (yason:encode-object-element "@context" (json-ld-context obj)))
(when id
(yason:encode-object-element "@id" (json-ld-id obj)))
(when type
(yason:encode-object-element "@type" (json-ld-type obj))))
(mapcar (lambda (alist-cell)
(yason:encode-object-element (car alist-cell)
(cdr alist-cell)))
(json-ld-etc obj)))
@ -78,8 +111,9 @@ encoding as @type’s value. If only the CLOS class-name is provided, @type will
not be encoded for this object. not be encoded for this object.
DIRECT-SUPERCLASSES is a list of JSON-LD CLOS classes, whose slots and context 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 this should inherit. JSON-LD-OBJECT should be somewhere in the hierarchy, in order
to provide “@context”; if no superclasses are provided, JSON-LD-TYPE is default. to provide “@context”, “@id”, and “@type”; if no superclasses are provided,
JSON-LD-OBJECT is default.
CONTEXT is a context hash-table, parsed from a JSON-LD context by JSON-LD:PARSE 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 or JSON-LD:PARSE-CONTEXT. Any terms defined in this context will be used to
@ -94,13 +128,7 @@ encoded nor decoded in JSON.
SLOT-OPTIONS are key/value pairs in the format of DEFCLASS’es slot-options. SLOT-OPTIONS are key/value pairs in the format of DEFCLASS’es slot-options.
Keywords such as :INITFORM, :DOCUMENTATION, etc. can be used. Keywords such as :INITFORM, :DOCUMENTATION, etc. can be used.
There are two keywords with behavior unlike DEFCLASS, however: There is one keyword with behavior unlike DEFCLASS, however — :ACCESSOR.
: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 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. PLACE-RADIUS for the class PLACE and the slot RADIUS.
@ -115,17 +143,15 @@ Here is a brief example partially defining the “Place” type from ActivityStr
((altitude “altitude” ((altitude “altitude”
:documentation “Indicates the altitude of a place.”) :documentation “Indicates the altitude of a place.”)
(latitude “latitude” (latitude “latitude”
:required T
:documentation “The latitude of a place.”) :documentation “The latitude of a place.”)
(longitude “longitude” (longitude “longitude”
:required T
:documentation “The longitude of a place.”)))" :documentation “The longitude of a place.”)))"
`(let ((json-class `(let ((json-class
(define-json-clos-class ,names (define-json-clos-class ,names
,(or direct-superclasses `(json-ld-type)) ,(or direct-superclasses `(json-ld-object))
,direct-slots ,options))) ,direct-slots ,options)))
(define-json-type-encoder ,(car names) ,direct-slots) (define-json-type-encoder ,(car names) ,direct-slots)
(register-json-type ',names ',direct-slots ,context) (register-json-type ',names (or ',direct-superclasses '(json-ld-object)) ',direct-slots ,context)
json-class)) json-class))
(defmacro define-json-clos-class (names direct-superclasses direct-slots options) (defmacro define-json-clos-class (names direct-superclasses direct-slots options)
@ -153,21 +179,15 @@ applying default slot-options, etc."
(defun json-type-implicit-slot-options (class-name slot-name) (defun json-type-implicit-slot-options (class-name slot-name)
"Return default property-list slot options for a json-type CLOS class." "Return default property-list slot options for a json-type CLOS class."
(list :initform nil (list :accessor (intern (format nil "~A-~A" class-name slot-name))))
:accessor (intern (format nil "~A-~A" class-name slot-name))))
(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* ((required (getf slot-opts :required)) (let* ((sans-accessor-maybe (if (and (find :accessor slot-opts)
(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))) (not (getf slot-opts :accessor)))
(alexandria:remove-from-plist sans-initform-maybe :accessor) (alexandria:remove-from-plist slot-opts :accessor)
sans-initform-maybe))) slot-opts)))
sans-accessor-maybe)) sans-accessor-maybe))
@ -181,28 +201,32 @@ CLASS is the class-name; see DEFINE-JSON-TYPE’s docstring about DIRECT-SLOTS."
(append (append
`(defmethod yason:encode-slots progn ((obj ,class))) `(defmethod yason:encode-slots progn ((obj ,class)))
(mapcar (lambda (slot) (mapcar (lambda (slot)
`(yason:encode-object-element ,(cadr slot) (slot-value obj ',(car slot)))) `(when (slot-boundp obj ',(car slot))
(yason:encode-object-element ,(cadr slot) (slot-value obj ',(car slot)))))
direct-slots))) direct-slots)))
;;; Parsing ;;; Parsing
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defun register-json-type (names direct-slots context) (defun register-json-type (names direct-superclasses direct-slots context)
"Register a JSON node-type. This allows PARSE to recognize the type (and "Register a JSON node-type. This allows PARSE to recognize the type (and
corresponding CLOS class) of a node." corresponding CLOS class) of a node."
(let* ((ctx (parse-context context)) (let* ((ctx (parse-context context))
(type-iri (getf (gethash (cadr names) ctx) :id)) (type-iri (getf (gethash (cadr names) ctx) :id))
(type-name (or type-iri (cadr names)))) (type-name (or type-iri (cadr names))))
(setf (gethash type-name *json-types*) (setf (gethash type-name *json-types*)
(json-type-registry-list names ctx direct-slots)))) (json-type-registry-list names direct-superclasses ctx direct-slots))))
(defun json-type-registry-list (names parsed-context direct-slots) (defun json-type-registry-list (names direct-superclasses parsed-context direct-slots)
"Return a REGISTER-JSON-TYPE-formed registry entry, a simple list of the form: "Return a REGISTER-JSON-TYPE-formed registry entry, a simple list of the form:
(TYPE-IRI (PROPERTY-NAME SLOT-NAME) ⋯ (PROPERTY-NAME SLOT-NAME)) (TYPE-IRI (PROPERTY-NAME SLOT-NAME) ⋯ (PROPERTY-NAME SLOT-NAME))
… where TYPE-IRI is the (hopefully) fully-resolved IRI form of the node-type’s … where TYPE-IRI is the (hopefully) fully-resolved IRI form of the node-type’s
name, though it might be unresolved if context was unprovided or lacking." name, though it might be unresolved if context was unprovided or lacking."
(append (list (cons (car names) (cadr names))) (append
;; The class-name and type-name.
(list (cons (car names) (cadr names)))
;; Add the class’es direct slots.
(mapcar (mapcar
(lambda (slot) (lambda (slot)
(when (cadr slot) (when (cadr slot)
@ -212,7 +236,16 @@ name, though it might be unresolved if context was unprovided or lacking."
(url (or (getf ctx-item :id) (url (or (getf ctx-item :id)
property-name))) property-name)))
(cons url (cons slot-name property-name))))) (cons url (cons slot-name property-name)))))
direct-slots))) direct-slots)
;; Add the slots of parent-classes.
(reduce (lambda (slots-a slots-b)
(append slots-a slots-b))
(mapcar (lambda (class-name)
(let* ((type-name (class-json-type-name class-name))
(type-registry (gethash type-name *json-types*)))
(if type-registry
type-registry)))
direct-superclasses))))
(defun parse (str) (defun parse (str)
"Parse the JSON-LD document contained in STR." "Parse the JSON-LD document contained in STR."
@ -240,11 +273,10 @@ name, though it might be unresolved if context was unprovided or lacking."
(getf val :id)))) (getf val :id))))
;; Now, actually parse. ;; Now, actually parse.
(let* ((parsed-table (parse-table-inplace table ctx)) (let* ((parsed-table (parse-table-inplace table ctx))
(type (identify-json-type table ctx rev-ctx)) (type (identify-json-type table ctx))
(typedef (gethash type *json-types*))) (type-def (or (gethash type *json-types*)
(if typedef (gethash "*" *json-types*))))
(parse-table-into-object parsed-table typedef ctx rev-ctx) ; We prefer this! (parse-table-into-object parsed-table type-def ctx rev-ctx))))
parsed-table)))) ; … but just in case you wanna use an undefined type…
(defun parse-table-inplace (table ctx) (defun parse-table-inplace (table ctx)
"Expand a YASON-parsed JSON-LD node-object in TABLE. That is, replace all "Expand a YASON-parsed JSON-LD node-object in TABLE. That is, replace all
@ -279,17 +311,17 @@ CTX is the according parsed-context, and REV-CTX is the reversed
(lambda (property value) (lambda (property value)
(let* ((property-def (assoc property type-def :test #'equal)) (let* ((property-def (assoc property type-def :test #'equal))
(slot-name (second property-def)) (slot-name (second property-def))
(etc-value (slot-value obj 'etc))) (etc-value (slot-value obj '.etc)))
(if property-def (if property-def
(setf (slot-value obj slot-name) value) (setf (slot-value obj slot-name) value)
(setf (slot-value obj 'etc) (setf (slot-value obj '.etc)
(append etc-value (append etc-value
(list (cons property value))))))) (list (cons property value)))))))
table) table)
(setf (slot-value obj '@context) (gethash "@context" table)) (setf (slot-value obj '@context) (gethash "@context" table))
obj)) obj))
(defun identify-json-type (table ctx rev-ctx) (defun identify-json-type (table ctx)
"Given an parsed JSON-LD object’s hash-TABLE, return the name/IRI of the "Given an parsed JSON-LD object’s hash-TABLE, return the name/IRI of the
JSON-type that best suits the object — using the types registered into JSON-type that best suits the object — using the types registered into
*JSON-TYPES* with REGISTER-JSON-TYPE." *JSON-TYPES* with REGISTER-JSON-TYPE."
@ -297,6 +329,13 @@ JSON-type that best suits the object — using the types registered into
(or (getf (gethash type ctx) :id) (or (getf (gethash type ctx) :id)
type))) type)))
(defun class-json-type-name (class-name)
"Return the name (IRI) of a registered JSON-type its CLOS class’es name."
(loop for iri being the hash-keys in *json-types*
for registry being the hash-values in *json-types*
if (eq class-name (caar registry))
return iri))
;;; Context-parsing ;;; Context-parsing