From 1340707f1caaf8c27db4e612ac6dec6367b67522 Mon Sep 17 00:00:00 2001 From: Jaidyn Ann <10477760+JadedCtrl@users.noreply.github.com> Date: Sat, 29 Jun 2024 19:11:29 -0500 Subject: [PATCH] =?UTF-8?q?Begin=20a=20=E2=80=9Cgood-enough=E2=80=9D=20JSO?= =?UTF-8?q?N-LD=20parser?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- activity-servist.asd | 22 +++++++ src/json-ld.lisp | 141 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 163 insertions(+) create mode 100644 src/json-ld.lisp diff --git a/activity-servist.asd b/activity-servist.asd index 2e1b576..dde53c8 100644 --- a/activity-servist.asd +++ b/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 " + :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 " + :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) diff --git a/src/json-ld.lisp b/src/json-ld.lisp new file mode 100644 index 0000000..b45c0f2 --- /dev/null +++ b/src/json-ld.lisp @@ -0,0 +1,141 @@ +;;;; json-λd: (Aspiring) parser and encoder for JSON-LD data + +;; Copyright © 2024 Jaidyn Ann +;; +;; 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 . + +(defpackage #:activity-servist/json-ld + (:use #:cl) + (:nicknames "AS/JSON-LD" "JSON-LD")) + +(in-package #:activity-servist/json-ld) + +(defun parse (str) + (let ((ctx (make-hash-table :test #'equal)) + (parsed (yason:parse str))) + (values (parse-item parsed ctx) + ctx))) + +(defun parse-item (item &optional ctx) + (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) + (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 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 iterations aren’t useful or +all terms are resolved and parsed. +These unresolved terms are generally keys mapped to compacted IRIs, whose prefix +(which ought be a separate term in CTX) hasn’t yet been parsed. A compacted IRI +looks like “prefix:suffix”. + UNRESOLVED-TERMS => ((“Laughing” . “xd:laughing”))" + (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 keys to the CTX +hash-table. Currently a stub, unimplemented." + nil) + +(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)) + +(defun ld-keyword-p (str) + "Return whether or not a string is a JSON-LD keyword." + (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 comapcted IRI, uncompact it into its full form, with CTX being a +hash-table containing its context." + (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." + (and (find #\: iri) + (not (search "://" iri)) + (not (equal iri "_:"))))