Begin a “good-enough” JSON-LD parser
This commit is contained in:
parent
54a5b1f434
commit
1340707f1c
|
@ -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)
|
||||
|
|
|
@ -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 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 "_:"))))
|
Ŝarĝante…
Reference in New Issue