Reorganization, commenting; no functional change

So that parsing foreign objects at least doesn’t
cause us to lose any data.

activity-servist.asd

@@ -27,6 +27,17 @@
                (:file "src/activity-vocabulary")))
 
 
+(asdf:defsystem "activity-servist/json-ld"
+  :version "0.0"
+  :license "AGPLv3"
+  :description "A fragile and meek JSON-LD parser and encoder."
+  :author "Jaidyn Ann <jadedctrl@posteo.at>"
+  :homepage "https://hak.xwx.moe/jadedctrl/activity-servist"
+
+  :depends-on ("alexandria" "closer-mop" "str" "yason")
+  :components ((:file "src/json-ld")))
+
+
 (asdf:defsystem "activity-servist/signatures"
   :version "0.0"
   :license "AGPLv3"
@@ -41,6 +52,15 @@
 
 ;;; Tests
 ;;; —————————————————————————————————————
+(asdf:defsystem "activity-servist/tests/json-ld"
+  :version "0.0"
+  :license "AGPLv3"
+  :author "Jaidyn Ann <jadedctrl@posteo.at>"
+  :description "Tests for the the activity-servist/json-ld package."
+
+  :depends-on (:activity-servist/json-ld :alexandria :lisp-unit2)
+  :components ((:file "t/json-ld")))
+
 (asdf:defsystem "activity-servist/tests/activity-streams"
   :version "0.0"
   :license "AGPLv3"
@@ -68,6 +88,7 @@
   :description "Tests for all activity-servist subpacakges."
 
   :depends-on (:activity-servist/tests/activity-streams
+               :activity-servist/tests/json-ld
                :activity-servist/tests/signatures
                :alexandria :lisp-unit2)
   :components ((:file "t/t")))
@@ -79,5 +100,6 @@
      (eval (read-from-string (format nil "(~A:run-with-summary)" ',package)))))
 
 (define-asdf-testing activity-servist/tests/activity-streams)
+(define-asdf-testing activity-servist/tests/json-ld)
 (define-asdf-testing activity-servist/tests/signatures)
 (define-asdf-testing activity-servist/tests)

src/activity-streams.lisp

@@ -26,8 +26,10 @@
    :*ap-packages* :*default-class*
    ;; Classes
    :object
+   ;; Accessors
+   :object-@context :object-unsupported
    ;; Slots
-   :@context :type))
+   :@context :@type :type :@id :id :unsupported))
 
 (in-package #:activity-servist/activity-streams)
 
@@ -44,7 +46,7 @@ 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 MISC slot.
+corresponding slots are placed in the UNSUPPORTED slot.
 The class you choose should inherit ACTIVITY-SERVIST/ACTIVITY-STREAMS:OBJECT.")
 
 ;; Private, internal variable.
@@ -75,8 +77,15 @@ 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) ; Encoded in YASON:ENCODE-OBJECT using *@context*
-              (setq *@context* (merge-@contexts *@context* value)))
+       (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
@@ -89,8 +98,30 @@ again and again, by YASON:ENCODE-SLOTS."
 ;;; Core class
 ;;; ————————————————————————————————————————
 (defclass object ()
-  ((@context :initform "https://www.w3.org/ns/activitystreams")
-   (type)))
+  ((@context          :initform nil)
+   (as/as:@type       :initform nil)
+   (as/as:type        :initform nil)
+   (as/as:@id         :initform nil)
+   (as/as:id          :initform nil)
+   (as/as:unsupported :initform nil :accessor object-unsupported)))
+
+
+
+;;; Accessors
+;;; ————————————————————————————————————————
+(defgeneric object-@context (obj)
+  (:documentation "Accessor for an object’s associated JSON-LD @context.
+As @context can sometimes vary on an object’s contents, on-the-fly, this
+method is invoked during JSON encoding of an object. The @CONTEXT
+slot-value should be prioritized over the @CONTEXT value is calculated
+by this method."))
+
+(defmethod object-@context ((obj object))
+  (or (slot-value obj '@context)
+      "https://www.w3.org/ns/activitystreams"))
+
+(defmethod (setf object-@context) (context (obj object))
+  (setf (slot-value obj '@context) context))
 
 
 
@@ -107,10 +138,15 @@ again and again, by YASON:ENCODE-SLOTS."
          (obj         (make-instance class)))
     (loop for key being each hash-key of table
           for val being each hash-value of table
-          do (let ((slot-sym (car (find-registered-symbols (param-case key))))
-                   (val      (parse-value val)))
-               (when slot-sym
-                 (setf (slot-value obj slot-sym) val))))
+          do (let* ((slot-name (string-upcase (param-case key)))
+                    (slot-sym  (car (find-registered-symbols slot-name)))
+                    (val       (parse-value val)))
+               (handler-case
+                   (setf (slot-value obj slot-sym) val)
+                 (error nil
+                   (setf (slot-value obj 'unsupported)
+                         (append (ignore-errors (slot-value obj 'unsupported))
+                                 (list (cons (intern slot-name) val))))))))
     obj))
 
 (defun parse-value (val)
@@ -160,10 +196,10 @@ inherited class). Each slot’s name is converted to camel-case, as per conventi
      (let ((*@context* 'top-level))
        (yason:encode-object obj)))
     (symbol ; In the top-level, encode slots and then @context.
-     (setq *@context* (slot-value obj '@context))
+     (setq *@context* (object-@context obj))
      (yason:with-object ()
-      (yason:encode-slots obj)
-      (yason:encode-object-element "@context" *@context*)))
+       (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)))))

src/json-ld.lisp

@@ -0,0 +1,183 @@
+;;;; json-λd: (Aspiring) parser and encoder for JSON-LD data
+
+;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
+;;
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU Affero General Public License
+;; as published by the Free Software Foundation, either version 3 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU Affero General Public License for more details.
+;;
+;; 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/>.
+
+(defpackage #:activity-servist/json-ld
+  (:use #:cl)
+  (:nicknames "AS/JSON-LD" "JSON-LD"))
+
+(in-package #:activity-servist/json-ld)
+
+
+;;; Globals
+;;; ————————————————————————————————————————
+(defvar *http-cache* (make-hash-table :test #'equal))
+
+
+
+;;; Parsing
+;;; ————————————————————————————————————————
+(defun parse (str)
+  "Parse the JSON-LD document contained in STR."
+  (let ((ctx    (make-hash-table :test #'equal))
+        (parsed (yason:parse str)))
+    (values (parse-item parsed ctx)
+            ctx)))
+
+(defun parse-item (item &optional ctx)
+  "Parse an individual ITEM of a YASON-decoded JSON-LD document."
+  (typecase item
+    (hash-table (parse-object item ctx))
+    (list       (mapcar (lambda (a) (parse-item a ctx)) item))
+    (T          item)))
+
+(defun parse-object (table &optional ctx)
+  "Parse a JSON “node object” (as decoded by YASON into a hash-TABLE."
+  (let ((ctx (parse-context (gethash "@context" table) ctx)))
+    (maphash
+     (lambda (key val)
+       (alexandria:when-let ((key-iri (gethash key ctx)))
+         (remhash key table)
+         (setf (gethash key-iri table)
+               (parse-item
+                val (or (and (hash-table-p val) (alexandria:copy-hash-table ctx))
+                        ctx)))))
+     table)
+    table))
+
+(defun parse-context (ctx-list &optional (ctx (make-hash-table :test #'equal)))
+  "Parse a JSON-LD map’s @context contents into a hash-table mapping string keys
+to IRIs."
+  (let ((ctx-list   (if (listp ctx-list) ctx-list (list ctx-list)))
+        (unresolved '()))
+    (mapcar (lambda (ctx-list-item)
+              (nconc unresolved
+                     (parse-context-item ctx ctx-list-item)))
+            ctx-list)
+    (repeat-parse-context ctx unresolved)))
+
+(defun repeat-parse-context (ctx unresolved-terms)
+  "Helper function for PARSE-CONTEXT.
+Takes an association list of UNRESOLVED-TERMS, and repeats context-parsing until
+all terms are resolved and parsed (or it’s clear that this isn’t possible).
+
+These unresolved terms are terms mapped to compacted IRIs whose prefix hasn’t yet
+been aprsed into CTX. See UNCOMPACT-IRI and COMPACT-IRI-P for more info on IRIs."
+  (let* ((unresolved-table (alexandria:alist-hash-table unresolved-terms))
+         (now-unresolved   (parse-context-map ctx unresolved-table)))
+    (cond ((not now-unresolved)
+           ctx)
+          ((eq (length now-unresolved)
+               (length unresolved-terms))
+           (values ctx now-unresolved)
+           (error 'unresolved :message
+                  (format nil "Compact IRI could not be resolved: ~A" now-unresolved)))
+          (T
+           (repeat-parse-context ctx now-unresolved)))))
+
+(defun parse-context-item (ctx item)
+  "Parse an individual ITEM in a JSON-LD map’s @context array.
+All terms found in the ITEM are then added to the CTX hash-table.
+Returns an association list containing terms in the item that couldn’t be
+resolved, likely compacted keys conned with compacted IRIs whose prefix hasn’t
+yet been parsed into CTX."
+  (typecase item
+   (string     (parse-remote-context ctx item))
+   (hash-table (parse-context-map    ctx item))
+   (:otherwise nil)))
+
+(defun parse-remote-context (ctx uri)
+  "Parse a remote JSON-LD context at URI, adding its terms to the CTX
+hash-table."
+  (let* ((headers '(("Accept" . "application/json,application/ld+json")))
+         (str     (caching-http-get uri :headers headers))
+         (parsed  (yason:parse str)))
+    (parse-context (gethash "@context" parsed) ctx)))
+
+(defun parse-context-map (ctx table)
+  "Parse an map item of a JSON-LD @context (which has been parsed by YASON into
+a hash-TABLE).
+Add all terms found to the hash-table CTX.
+Returns an association list of terms that couldn’t be resolved, likely compacted
+IRI values whose prefix hasn’t yet been parsed into CTX."
+  (let ((unresolvable '()))
+    (maphash
+     (lambda (term val)
+       (let* ((iri
+                (typecase val
+                  (string val)
+                  (hash-table (gethash "@id" val))))
+              (noncompact-iri
+                (if (ld-keyword-p iri)
+                    iri
+                    (uncompact-iri iri ctx))))
+         (cond ((and (compacted-iri-p iri)
+                     (not noncompact-iri))
+                (push (cons term iri) unresolvable))
+               ((not (gethash term ctx))
+                (setf (gethash term ctx) noncompact-iri)))))
+     table)
+    unresolvable))
+
+
+
+;;; Parsing utility
+;;; ————————————————————————————————————————
+(defun ld-keyword-p (str)
+  "Return whether or not a string is a JSON-LD keyword, as defined in the spec.
+"
+  (member (string-downcase str)
+          '("@base" "@container" "@context" "@direction" "@graph" "@id" "@import"
+            "@included" "@index" "@json" "@language" "@list" "@nest" "@none"
+            "@prefix" "@propagate" "@protected" "@reverse" "@set" "@type"
+            "@value" "@version" "@vocab")))
+
+(defun uncompact-iri (iri ctx)
+  "Given a compacted IRI, uncompact it into its normal form, with CTX being a
+hash-table containing terms mapped to IRIs.
+For instance, if CTX maps “xd” to “http://lol.net/ns#”, then:
+    (uncompact-iri “xd:laughing” CTX) => “http://lol.net/ns#laughing”
+https://www.w3.org/TR/json-ld11/#compact-iris"
+  (if (compacted-iri-p iri)
+      (destructuring-bind (prefix suffix)
+          (str:split #\: iri)
+        (alexandria:when-let ((prefix-iri (gethash (string-downcase prefix) ctx)))
+         (format nil "~A~A" prefix-iri suffix)))
+      iri))
+
+(defun compacted-iri-p (iri)
+  "Return whether or not an IRI is in compacted “prefix:suffix” form.
+https://www.w3.org/TR/json-ld11/#compact-iris"
+  (and (find #\: iri)
+       (not (search "://" iri))
+       (not (equal iri "_:"))))
+
+
+
+;;; Utility
+;;; ————————————————————————————————————————
+(defun caching-http-get (uri &key headers)
+  "Makes a GET request to URI, returning the resultant string.
+Each resultant string is cached in the *HTTP-CACHE* global variable; if the same
+URI is requested more than once, the cached version will subsequently be
+returned."
+  (or (gethash uri *http-cache*)
+      (setf (gethash uri *http-cache*)
+            (http-get uri :headers headers))))
+
+(defun http-get (uri &key headers)
+  "Makes a GET request to URI, returning the resultant string."
+  (dexador:get uri :headers headers :force-string 't))