Begin a “good-enough” JSON-LD parser

This commit is contained in:
Jaidyn Ann 2024-06-29 19:11:29 -05:00
parent 54a5b1f434
commit 1340707f1c
2 changed files with 163 additions and 0 deletions

View File

@ -27,6 +27,17 @@
(:file "src/activity-vocabulary"))) (: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" (asdf:defsystem "activity-servist/signatures"
:version "0.0" :version "0.0"
:license "AGPLv3" :license "AGPLv3"
@ -41,6 +52,15 @@
;;; Tests ;;; 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" (asdf:defsystem "activity-servist/tests/activity-streams"
:version "0.0" :version "0.0"
:license "AGPLv3" :license "AGPLv3"
@ -68,6 +88,7 @@
:description "Tests for all activity-servist subpacakges." :description "Tests for all activity-servist subpacakges."
:depends-on (:activity-servist/tests/activity-streams :depends-on (:activity-servist/tests/activity-streams
:activity-servist/tests/json-ld
:activity-servist/tests/signatures :activity-servist/tests/signatures
:alexandria :lisp-unit2) :alexandria :lisp-unit2)
:components ((:file "t/t"))) :components ((:file "t/t")))
@ -79,5 +100,6 @@
(eval (read-from-string (format nil "(~A:run-with-summary)" ',package))))) (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/activity-streams)
(define-asdf-testing activity-servist/tests/json-ld)
(define-asdf-testing activity-servist/tests/signatures) (define-asdf-testing activity-servist/tests/signatures)
(define-asdf-testing activity-servist/tests) (define-asdf-testing activity-servist/tests)

141
src/json-ld.lisp Normal file
View File

@ -0,0 +1,141 @@
;;;; 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)
(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 maps @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 arent 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) hasnt 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 maps @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 couldnt be
resolved, likely compacted keys conned with compacted IRIs whose prefix hasnt
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 couldnt be resolved, likely compacted
IRI values whose prefix hasnt 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 "_:"))))