activity-servist.asd

@@ -27,17 +27,6 @@
                (: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"
@@ -52,15 +41,6 @@
 
 ;;; 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"
@@ -88,7 +68,6 @@
   :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")))
@@ -100,6 +79,5 @@
      (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,10 +26,8 @@
    :*ap-packages* :*default-class*
    ;; Classes
    :object
-   ;; Accessors
-   :object-@context :object-unsupported
    ;; Slots
-   :@context :@type :type :@id :id :unsupported))
+   :@context :type))
 
 (in-package #:activity-servist/activity-streams)
 
@@ -46,7 +44,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 UNSUPPORTED slot.
+corresponding slots are placed in the MISC slot.
 The class you choose should inherit ACTIVITY-SERVIST/ACTIVITY-STREAMS:OBJECT.")
 
 ;; Private, internal variable.
@@ -77,15 +75,8 @@ 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*
+       (cond ((eq key '@context) ; Encoded in YASON:ENCODE-OBJECT using *@context*
-              (setq *@context* (merge-@contexts *@context* (object-@context obj))))
+              (setq *@context* (merge-@contexts *@context* value)))
-             ((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
@@ -98,30 +89,8 @@ again and again, by YASON:ENCODE-SLOTS."
 ;;; Core class
 ;;; ————————————————————————————————————————
 (defclass object ()
-  ((@context          :initform nil)
+  ((@context :initform "https://www.w3.org/ns/activitystreams")
-   (as/as:@type       :initform nil)
+   (type)))
-   (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))
 
 
 
@@ -138,15 +107,10 @@ by this method."))
          (obj         (make-instance class)))
     (loop for key being each hash-key of table
           for val being each hash-value of table
-          do (let* ((slot-name (string-upcase (param-case key)))
+          do (let ((slot-sym (car (find-registered-symbols (param-case key))))
-                    (slot-sym  (car (find-registered-symbols slot-name)))
+                   (val      (parse-value val)))
-                    (val       (parse-value val)))
+               (when slot-sym
-               (handler-case
+                 (setf (slot-value obj slot-sym) val))))
-                   (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)
@@ -196,10 +160,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* (object-@context obj))
+     (setq *@context* (slot-value obj '@context))
      (yason:with-object ()
-       (yason:encode-slots obj)
+      (yason:encode-slots obj)
-       (yason:encode-object-element "@context" *@context*)))
+      (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

@@ -1,183 +0,0 @@
-;;;; 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))