activity-servist.asd

@@ -87,7 +87,7 @@
   :author "Jaidyn Ann <jadedctrl@posteo.at>"
   :description "Tests for all activity-servist subpacakges."
 
-  :depends-on (:activity-servist/tests/activity-vocabulary
+  :depends-on (:activity-servist/tests/activity-streams
                :activity-servist/tests/json-ld
                :activity-servist/tests/signatures
                :alexandria :lisp-unit2)

src/activity-vocabulary.lisp

@@ -81,13 +81,7 @@ Items of DIRECT-CHILDREN should be of the form,
 ;; https://www.w3.org/ns/activitystreams#Object
 ;; The root of all evil in the world.
 (json-ld::define-json-type (object "Object") () "https://www.w3.org/ns/activitystreams"
-  ((@id
-    "id"
-    :documentation "Provides the globally unique identifier for an Object.")
-   (@type
-    "type"
-    :documentation "Identifies the Object type. Multiple values may be specified.")
-   (attachment
+  ((attachment
     "attachment"
     :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
@@ -176,13 +170,7 @@ The notion of “context” used is intentionally vague. The intended function i
 ;; looking at Link’s properties), but it’s implied by the Mention example.
 (json-ld:define-json-type (link "Link") ()
   "https://www.w3.org/ns/activitystreams"
-  ((@id
-    "id"
-    :documentation "Provides the globally unique identifier for a Link.")
-   (@type
-    "type"
-    :documentation "Identifies the Link type. Multiple values may be specified.")
-   (height
+  ((height
     "height"
     :documentation "On a Link, specifies a hint as to the rendering height in device-independent pixels of the linked resource.")
    (href
@@ -192,7 +180,7 @@ The notion of “context” used is intentionally vague. The intended function i
     "hreflang"
     :documentation "Hints as to the language used by the target resource. Value MUST be a [BCP47] Language-Tag.")
    (media-type
-    "mediaType"
+    "media-type"
     :documentation "Identifies the MIME media type of the referenced resource.")
    (name
     "name"
@@ -444,13 +432,10 @@ Either of the ANY-OF and ONE-OF properties MAY be used to express possible answe
   "https://www.w3.org/ns/activitystreams"
   ((subject
     "subject"
-    :documentation "The subject property identifies one of the connected individuals. For instance, for a Relationship object describing “John is related to Sally”, subject would refer to John.")
-   (object
-    "object"
-    :documentation "Describes the entity to which the subject is related.")
+    :documentation "On a Relationship object, the subject property identifies one of the connected individuals. For instance, for a Relationship object describing “John is related to Sally”, subject would refer to John.")
    (relationship
     "relationship"
-    :documentation "The relationship property identifies the kind of relationship that exists between subject and object."))
+    :documentation "On a Relationship object, the relationship property identifies the kind of relationship that exists between subject and object."))
   (:documentation "Describes a relationship between two individuals. The subject and object properties are used to identify the connected individuals."))
 
 

src/json-ld.lisp

@@ -19,12 +19,7 @@
   (:use #:cl)
   (:nicknames "AS/JSON-LD" "JSON-LD")
   (:export
-   ;; Functions/Macros
    #:parse #:define-json-type
-   ;; Symbols
-   #:no-@context
-   ;; Globals
-   #:*default-json-type*
    ;; Accessors
    #:json-ld-context #:json-ld-etc #:json-ld-id #:json-ld-type
    ;; Slots
@@ -35,13 +30,6 @@
 
 ;;; Globals
 ;;; ————————————————————————————————————————
-(defvar *default-json-type* "*"
-  "When parsing JSON-LD, objects of unrecognized types will be assumed to be
-of this type. Should be a string, the IRI corresponding to a registered type.
-For example: “https://www.w3.org/ns/activitystreams#Object”
-
-The default value “*” refers to the base JSON-LD-OBJECT type.")
-
 (defvar *http-cache* (make-hash-table :test #'equal))
 (defvar *json-types* (make-hash-table :test #'equal))
 
@@ -91,13 +79,10 @@ 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-object))
-  (let ((slot-@context (slot-value obj '@context)))
-    (unless (eq slot-@context 'no-@context)
-      (or slot-@context
-          "https://www.w3.org/ns/activitystreams"))))
+  (or (slot-value obj '@context)
+      "https://www.w3.org/ns/activitystreams"))
 
 (defmethod yason:encode-slots progn ((obj json-ld-object))
-  (flatten-contained-contexts obj)
   (let ((context (json-ld-context obj))
         (id      (json-ld-id obj))
         (type    (json-ld-type obj)))
@@ -262,9 +247,10 @@ name, though it might be unresolved if context was unprovided or lacking."
    (reduce (lambda (slots-a slots-b)
              (append slots-a slots-b))
            (mapcar (lambda (class-name)
-                     (let* ((type-def (class-json-type-definition class-name)))
-                       (when type-def
-                         (cdr type-def))))
+                     (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)
@@ -286,9 +272,9 @@ name, though it might be unresolved if context was unprovided or lacking."
   (let ((ctx (parse-context (gethash "@context" table) ctx)))
     ;; Now, actually parse.
     (let* ((parsed-table (parse-table-inplace table ctx))
-           (type         (identify-json-type parsed-table ctx))
+           (type         (identify-json-type table ctx))
            (type-def      (or (gethash type *json-types*)
-                             (gethash *default-json-type* *json-types*))))
+                              (gethash "*"  *json-types*))))
       (parse-table-into-object parsed-table type-def ctx))))
 
 (defun parse-table-inplace (table ctx)
@@ -348,12 +334,6 @@ JSON-type that best suits the object — using the types registered into
         if (eq class-name (caar registry))
           return iri))
 
-(defun class-json-type-definition (class-name)
-  "Return the type-definition from the the registry of JSON types (*JSON-TYPES*),
-based on a CLOS class-name. It is of the form,
-  ((CLASS-NAME TYPE-NAME) (SLOT-NAME PROPERTY-NAME) ⋯ (SLOT-NAME PROPERTY-NAME))"
-  (gethash (class-json-type-name class-name) *json-types*))
-
 
 
 ;;; Context-parsing
@@ -437,72 +417,6 @@ IRI values whose prefix hasn’t yet been parsed into CTX."
     unresolvable))
 
 
-
-;;; Context-normalization
-;;; ————————————————————————————————————————
-(defun flatten-contained-contexts (obj)
-  "“Flattens” the @CONTEXTs of a JSON-LD object and the @CONTEXTs of any contained
-objects, recursively. That is, redundant @CONTEXT-definitions are removed — we
-try to concentrate everything in the top-level object’s @CONTEXT slot.
-This is useful for ensuring the same @CONTEXT doesn’t get output a million times
-during JSON-encoding with YASON:ENCODE."
-  (loop for subobj in (cdr (contained-json-objects obj))
-        do
-           (progn
-             (let ((old-context    (json-ld-context obj))
-                   (old-subcontext (json-ld-context subobj)))
-               (when (and old-subcontext
-                          (not (equal old-context old-subcontext)))
-                 (setf (slot-value obj '@context)
-                       (append (if (listp old-context)
-                                   old-context
-                                   (list old-context))
-                               old-subcontext))))
-             (setf (slot-value subobj '@context) 'no-@context))))
-
-(defun json-slot-values (obj)
-  "Return the values of all registered slots/properties of a JSON-LD-OBJECT.
-Unregistered slots that don’t get encoded/decoded are ignored."
-  (let* ((type-def  (class-json-type-definition (class-name (class-of obj))))
-         (slot-defs (cdr type-def)))
-    (remove-if
-     #'not
-     (append
-      (mapcar (lambda (slot-def)
-                (let* ((slot-name  (cadr slot-def)))
-                  (and (slot-exists-p obj slot-name)
-                       (slot-boundp obj slot-name)
-                       (slot-value obj slot-name))))
-              slot-defs)
-      (mapcar (lambda (etc-cons)
-                (cdr etc-cons))
-              (slot-value obj '.etc))))))
-
-(defun contained-json-objects (item)
-  "Given ITEM of arbitrary type, return all JSON-LD-OBJECTs contained within,
-recursively. Lists, hash-tables, and the slots of JSON-LD-OBJECTs are explored."
-  (typecase item
-    (cons           (reduce
-                     (lambda (a b)
-                       (append a b))
-                     (mapcar (lambda (a) (contained-json-objects a))
-                             item)))
-    (hash-table     (let ((ret '()))
-                      (maphash
-                       (lambda (k v)
-                         (setq ret
-                               (append ret (contained-json-objects v))))
-                       item)
-                      ret))
-    (json-ld-object (append
-                     (list item)
-                     (reduce
-                      (lambda (b c)
-                       (append b c))
-                      (mapcar (lambda (a) (contained-json-objects a))
-                              (json-slot-values item)))))))
-
-
 
 ;;; IRI/keywords
 ;;; ————————————————————————————————————————

t/activity-vocabulary.lisp

@@ -24,8 +24,7 @@
 
 (defun run ()
   "Run all ACTIVITY-VOCABULARY tests."
-  (let ((json-ld:*default-json-type* "https://www.w3.org/ns/activitystreams#Object"))
-    (lisp-unit2:run-tests :package :activity-servist/tests/activity-vocabulary)))
+  (lisp-unit2:run-tests :package :activity-servist/tests/activity-vocabulary))
 
 (defun run-with-summary ()
   "Run tests with summary for ACTIVITY-VOCABULARY."
@@ -38,7 +37,7 @@
 ;;; ————————————————————————————————————————
 (defmacro relative-pathname (path)
   "Return an absolute path adding the relative PATH to the system’s path."
-  `(asdf:system-relative-pathname :activity-servist/tests/activity-vocabulary ,path))
+  `(asdf:system-relative-pathname :activity-servist/tests/activity-streams ,path))
 
 (defmacro define-json-test (path tags)
   "Define a lisp-unit2 test for parsing of the given JSON file.