Split activity-vocab package into two
Now, ACTIVITY-VOCABULARY solely contains class definitions; all parsing/encoding is handled by the ACTIVITY-STREAMS package.
This commit is contained in:
parent
5f1903b741
commit
56d4706557
|
@ -15,26 +15,25 @@
|
||||||
:components ((:file "src/activity-servist")))
|
:components ((:file "src/activity-servist")))
|
||||||
|
|
||||||
|
|
||||||
(asdf:defsystem "activity-servist/activity-vocabulary"
|
(asdf:defsystem "activity-servist/activity-streams"
|
||||||
:version "0.0"
|
:version "0.0"
|
||||||
:license "AGPLv3"
|
:license "AGPLv3"
|
||||||
:description "AP-S subpackage for handling ActivityVocabulary parsing/encoding."
|
:description "A-S subpackage for handling ActivityStreams parsing/encoding."
|
||||||
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
||||||
:homepage "https://hak.xwx.moe/jadedctrl/activity-servist"
|
:homepage "https://hak.xwx.moe/jadedctrl/activity-servist"
|
||||||
|
|
||||||
:in-order-to ((test-op (test-op "activitypub/tests/activity-vocabulary")))
|
|
||||||
:depends-on ("alexandria" "closer-mop" "str" "yason")
|
:depends-on ("alexandria" "closer-mop" "str" "yason")
|
||||||
:components ((:file "src/activity-vocabulary")))
|
:components ((:file "src/activity-streams")
|
||||||
|
(:file "src/activity-vocabulary")))
|
||||||
|
|
||||||
|
|
||||||
(asdf:defsystem "activity-servist/signatures"
|
(asdf:defsystem "activity-servist/signatures"
|
||||||
:version "0.0"
|
:version "0.0"
|
||||||
:license "AGPLv3"
|
:license "AGPLv3"
|
||||||
:description "AP-S subpackage for handling HTTP signatures."
|
:description "A-S subpackage for handling HTTP signatures."
|
||||||
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
||||||
:homepage "https://hak.xwx.moe/jadedctrl/activity-servist"
|
:homepage "https://hak.xwx.moe/jadedctrl/activity-servist"
|
||||||
|
|
||||||
:in-order-to ((test-op (test-op "activitypub/tests/signatures")))
|
|
||||||
:depends-on ("cl-base64" "flexi-streams" "inferior-shell" "ironclad" "str")
|
:depends-on ("cl-base64" "flexi-streams" "inferior-shell" "ironclad" "str")
|
||||||
:components ((:file "src/signatures")))
|
:components ((:file "src/signatures")))
|
||||||
|
|
||||||
|
@ -42,14 +41,14 @@
|
||||||
|
|
||||||
;;; Tests
|
;;; Tests
|
||||||
;;; —————————————————————————————————————
|
;;; —————————————————————————————————————
|
||||||
(asdf:defsystem "activity-servist/tests/activity-vocabulary"
|
(asdf:defsystem "activity-servist/tests/activity-streams"
|
||||||
:version "0.0"
|
:version "0.0"
|
||||||
:license "AGPLv3"
|
:license "AGPLv3"
|
||||||
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
||||||
:description "Tests for the the activity-servist/signatures package."
|
:description "Tests for the the activity-servist/activity-streams package."
|
||||||
|
|
||||||
:depends-on (:activity-servist/activity-vocabulary :alexandria :lisp-unit2)
|
:depends-on (:activity-servist/activity-streams :alexandria :lisp-unit2)
|
||||||
:components ((:file "t/activity-vocabulary")))
|
:components ((:file "t/activity-streams")))
|
||||||
|
|
||||||
|
|
||||||
(asdf:defsystem "activity-servist/tests/signatures"
|
(asdf:defsystem "activity-servist/tests/signatures"
|
||||||
|
@ -68,7 +67,7 @@
|
||||||
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
||||||
:description "Tests for all activity-servist subpacakges."
|
:description "Tests for all activity-servist subpacakges."
|
||||||
|
|
||||||
:depends-on (:activity-servist/tests/activity-vocabulary
|
:depends-on (:activity-servist/tests/activity-streams
|
||||||
:activity-servist/tests/signatures
|
:activity-servist/tests/signatures
|
||||||
:alexandria :lisp-unit2)
|
:alexandria :lisp-unit2)
|
||||||
:components ((:file "t/t")))
|
:components ((:file "t/t")))
|
||||||
|
@ -79,6 +78,6 @@
|
||||||
`(defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system ',package))))
|
`(defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system ',package))))
|
||||||
(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-vocabulary)
|
(define-asdf-testing activity-servist/tests/activity-streams)
|
||||||
(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)
|
||||||
|
|
|
@ -0,0 +1,270 @@
|
||||||
|
;;;; activity-streams: Serialize/deserialize ActivityStreams objects.
|
||||||
|
|
||||||
|
;; 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 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 General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(defpackage #:activity-servist/activity-streams
|
||||||
|
(:use #:cl)
|
||||||
|
(:nicknames "AS/AS" "ACTIVITY-STREAMS")
|
||||||
|
(:export
|
||||||
|
;; Functions
|
||||||
|
:parse :encode
|
||||||
|
:define-class-encoders
|
||||||
|
;; Globals
|
||||||
|
:*ap-packages*
|
||||||
|
;; Classes
|
||||||
|
:object
|
||||||
|
;; Slots
|
||||||
|
:@context :type))
|
||||||
|
|
||||||
|
(in-package #:activity-servist/activity-streams)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; Globals
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
(defparameter *ap-packages* (list :activity-servist/activity-vocabulary *package*)
|
||||||
|
"A list of packages in which we should search for AP classes and slot-symbols
|
||||||
|
during JSON parsing. The class-name searched for is simply the value of the JSON
|
||||||
|
object’s “type” key. The package first in the list to export such a symbol
|
||||||
|
is the winner.")
|
||||||
|
|
||||||
|
;; Private, internal variable.
|
||||||
|
(defparameter *@context* nil
|
||||||
|
"Used in YASON:ENCODE to ensure that a single top-level @context can be
|
||||||
|
created where AP objects contain other AP objects in their slots.
|
||||||
|
This variable is overridden locally during encoding (LET), and should never be
|
||||||
|
modified globally (as we expect it to be nil in top-level objects.")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; Macros
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
;; This macro and the following function are related to JSON serialization; see
|
||||||
|
;; the below “JSON serialization” section for other related functions.
|
||||||
|
(defmacro define-yason-encode-slots (class)
|
||||||
|
"Define a YASON:ENCODE-SLOTS method for a CLASS, which simply encodes all of
|
||||||
|
CLASS’es slots with JSON keys based on the camel-cased slot name."
|
||||||
|
(append
|
||||||
|
`(defmethod yason:encode-slots progn ((obj ,class)))
|
||||||
|
(mapcar (yason-encode-slot-function)
|
||||||
|
(class-slots-activity-alist class))))
|
||||||
|
|
||||||
|
(defun yason-encode-slot-function ()
|
||||||
|
"Helper-function for the DEFINE-YASON-ENCODE-SLOTS macro.
|
||||||
|
This returns a function to create a quoted function that should be called for each slot,
|
||||||
|
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)))
|
||||||
|
((eq key 'type) ; Encode type based on class-name or TYPE slot
|
||||||
|
(yason:encode-object-element
|
||||||
|
"type" (or value
|
||||||
|
(class-pretty-name (class-of obj)))))
|
||||||
|
(value
|
||||||
|
(yason:encode-object-element ,(cdr slot-key-pair) value))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; Core class
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
(defclass object ()
|
||||||
|
((@context :initform "https://www.w3.org/ns/activitystreams")
|
||||||
|
(type)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; JSON parsing
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
(defun parse (string)
|
||||||
|
"Parse a string containing JSON into an ActivityPub object."
|
||||||
|
(parse-table (yason:parse string)))
|
||||||
|
|
||||||
|
(defun parse-table (table)
|
||||||
|
"Parse a hash-table corresponding to YASON-parsed JSON into an ActivityPub object."
|
||||||
|
(let* ((class (car (find-registered-classes (param-case (gethash "type" table)))))
|
||||||
|
(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))))
|
||||||
|
obj))
|
||||||
|
|
||||||
|
(defun parse-value (val)
|
||||||
|
"Parse the value of a key found in YASON-parsed JSON.
|
||||||
|
All ActivityPub objects (hash-tables containing “type”) will be parsed into
|
||||||
|
ActivityPub objects; all others will parsed into associative lists."
|
||||||
|
(typecase val
|
||||||
|
(hash-table (maybe-parse-table val))
|
||||||
|
(list (mapcar (lambda (a)
|
||||||
|
(if (hash-table-p a)
|
||||||
|
(maybe-parse-table a)
|
||||||
|
a))
|
||||||
|
val))
|
||||||
|
(t val)))
|
||||||
|
|
||||||
|
(defun maybe-parse-table (table)
|
||||||
|
"If a hash-table seems to be a valid ActivityPub object, attempt parsing it
|
||||||
|
into one. Otherwise, parse it into an associative list."
|
||||||
|
(if (gethash "type" table)
|
||||||
|
(parse-table table)
|
||||||
|
(alexandria:hash-table-alist table)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; JSON serialization
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
(defun define-class-encoders (classes)
|
||||||
|
"For each class in CLASSES, define an YASON:ENCODE-SLOTS method for that class,
|
||||||
|
which only encodes slots unique to that class (as ENCODE-SLOTS is called for each
|
||||||
|
inherited class). Each slot’s name is converted to camel-case, as per convention."
|
||||||
|
(mapcar (lambda (class)
|
||||||
|
(closer-mop:finalize-inheritance class)
|
||||||
|
(eval `(define-yason-encode-slots ,class)))
|
||||||
|
classes))
|
||||||
|
|
||||||
|
(defun encode (obj &optional (stream *standard-output*))
|
||||||
|
"Encode OBJ into JSON. A mere wrapper around YASON:ENCODE."
|
||||||
|
(yason:encode obj stream))
|
||||||
|
|
||||||
|
(defmethod yason:encode ((obj object) &optional (stream *standard-output*))
|
||||||
|
(yason:with-output (stream)
|
||||||
|
(yason:encode-object obj)))
|
||||||
|
|
||||||
|
(defmethod yason:encode-object ((obj object))
|
||||||
|
(typecase *@context*
|
||||||
|
(null ; If this is the top-level (non-nested) object, establish a @context.
|
||||||
|
(let ((*@context* 'top-level))
|
||||||
|
(yason:encode-object obj)))
|
||||||
|
(symbol ; In the top-level, encode slots and then @context.
|
||||||
|
(setq *@context* (slot-value obj '@context))
|
||||||
|
(yason:with-object ()
|
||||||
|
(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)))))
|
||||||
|
|
||||||
|
(defun class-slots-activity-alist (class)
|
||||||
|
"Return an associative list containing CLASSes slots’ symbols consed with
|
||||||
|
their sanitized string keys appropriate for ActivityVocabular custom.
|
||||||
|
A class with slots MAP-AWAY and COLLECTION-AGAIN would return
|
||||||
|
((MAP-AWAY . “mapAway”)(COLLECTION-AGAIN . “collectionAgain”))"
|
||||||
|
(alist-mapcdr #'camel-case
|
||||||
|
(class-slots-alist class)))
|
||||||
|
|
||||||
|
(defun merge-@contexts (a b)
|
||||||
|
"Given two @context lists, A and B, merge them into one JSON-LD @context list
|
||||||
|
containing both of their elements."
|
||||||
|
(cond ((equal a b) a)
|
||||||
|
((not b) a)
|
||||||
|
((not a) b)
|
||||||
|
((and (listp a)
|
||||||
|
(find b a :test #'equal))
|
||||||
|
a)
|
||||||
|
(T
|
||||||
|
(merge-lists
|
||||||
|
(if (listp a) a (list a))
|
||||||
|
(if (listp b) b (list b))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; Util
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
(defun camel-case (string)
|
||||||
|
"Convert a STRING to camel-casing. That is, casingLikeThis.
|
||||||
|
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
|
||||||
|
character at the start of the string gets erroneously (or at least undesireably,
|
||||||
|
to us) removed."
|
||||||
|
(keep-nonalphanumeric-prefix string
|
||||||
|
(str:camel-case string)))
|
||||||
|
|
||||||
|
(defun param-case (string)
|
||||||
|
"Convert a STRING to param-casing. That is, casing-like-this.
|
||||||
|
Wrapper around STR:PARAM-CASE, working around a bug that a non-alphanumeric
|
||||||
|
character at the start of the string gets erroneously (or at least undesireably,
|
||||||
|
to us) removed."
|
||||||
|
(keep-nonalphanumeric-prefix string
|
||||||
|
(str:param-case string)))
|
||||||
|
(defun camel-case (str)
|
||||||
|
"Convert a STRING to camel-casing.
|
||||||
|
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
|
||||||
|
character at the start of the string gets erroneously (or at least undesireably,
|
||||||
|
to us) removed."
|
||||||
|
(keep-nonalphanumeric-prefix str (str:camel-case str)))
|
||||||
|
|
||||||
|
(defun keep-nonalphanumeric-prefix (str child-str)
|
||||||
|
"This ensures that a CHILD-STR derived from STR has the same nonalphanumeric
|
||||||
|
prefix as STR, as some functions like to remove such prefixes."
|
||||||
|
(if (not (alphanumericp (aref str 0)))
|
||||||
|
(concatenate 'string
|
||||||
|
(string (aref str 0))
|
||||||
|
child-str)
|
||||||
|
child-str))
|
||||||
|
|
||||||
|
(defun class-pretty-name (class)
|
||||||
|
"Return a CLASS’es name in a “pretty” (sentence-capitalized) string."
|
||||||
|
(string-capitalize (symbol-name (class-name class))))
|
||||||
|
|
||||||
|
(defun merge-lists (a b)
|
||||||
|
"Given lists A and B, merge them into one list non-redundantly — all unique
|
||||||
|
items in each will be contained in the resultant list."
|
||||||
|
(append a (remove-if (lambda (item) (find item a :test #'equal)) b)))
|
||||||
|
|
||||||
|
(defun find-registered-symbols (str)
|
||||||
|
"Find all symbols identified by string STR within packages in the
|
||||||
|
*ap-packages* list."
|
||||||
|
(remove-if
|
||||||
|
#'not
|
||||||
|
(mapcar (lambda (package) (find-symbol (string-upcase str) package))
|
||||||
|
*ap-packages*)))
|
||||||
|
|
||||||
|
(defun find-registered-classes (str)
|
||||||
|
"Find all classes identified by string STR within pacakges in the
|
||||||
|
*ap-packages* list."
|
||||||
|
(remove-if
|
||||||
|
#'not
|
||||||
|
(mapcar (lambda (sym) (find-class sym))
|
||||||
|
(find-registered-symbols str))))
|
||||||
|
|
||||||
|
(defun alist-mapcdr (function alist)
|
||||||
|
"Apply a FUNCTION to all values (cdrs) of an ALIST’s pairs. Returns a new ALIST
|
||||||
|
of the same keys, whose values are the results of FUNCTION."
|
||||||
|
(mapcar
|
||||||
|
(lambda (cell)
|
||||||
|
(cons (car cell)
|
||||||
|
(funcall function (cdr cell))))
|
||||||
|
alist))
|
||||||
|
|
||||||
|
(defun class-slots-alist (class)
|
||||||
|
"Return an associative list of a CLASS’es direct slots (by symbol) matched with
|
||||||
|
their names as strings. For instance, a class with slots MAP-AWAY and
|
||||||
|
COLLECTION-AGAIN would return:
|
||||||
|
((MAP-AWAY . “MAP-AWAY”)(COLLECTION-AGAIN . “COLLECTION-AGAIN”)"
|
||||||
|
(mapcar
|
||||||
|
(lambda (slot)
|
||||||
|
(let ((name (closer-mop:slot-definition-name slot)))
|
||||||
|
(cons name (symbol-name name))))
|
||||||
|
(closer-mop:class-direct-slots class)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; Defining YASON:ENCODE-SLOTS
|
||||||
|
;;; ————————————————————————————————————————
|
||||||
|
(as/as:define-class-encoders (list (find-class 'object)))
|
|
@ -1,4 +1,4 @@
|
||||||
;;;; activity-vocabulary: Classes for ActivityVocabulary types.
|
;;;; activity-vocabulary: Base classes for ActivityStreams.
|
||||||
|
|
||||||
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
|
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
|
||||||
;;
|
;;
|
||||||
|
@ -22,21 +22,15 @@
|
||||||
;; One should never USE this package, since some class-names shadow
|
;; One should never USE this package, since some class-names shadow
|
||||||
;; core Common Lisp symbols! Beware! :P
|
;; core Common Lisp symbols! Beware! :P
|
||||||
(:export
|
(:export
|
||||||
;; Functions
|
|
||||||
:parse
|
|
||||||
;; Globals
|
|
||||||
:*ap-packages*
|
|
||||||
;; Classes
|
;; Classes
|
||||||
:accept :activity :add :announce :application :arrive :article :audio
|
:accept :activity :add :announce :application :arrive :article :audio
|
||||||
:collection :collection-page :create :delete :dislike :document :event :flag
|
:collection :collection-page :create :delete :dislike :document :event :flag
|
||||||
:follow :group :ignore :ignore :image :intransitive-activity :invite :join
|
:follow :group :ignore :ignore :image :intransitive-activity :invite :join
|
||||||
:leave :like :link :link :listen :move :note :object :offer
|
:leave :like :link :listen :move :note :object :offer :ordered-collection
|
||||||
:ordered-collection :ordered-collection-page :organization :page :person
|
:ordered-collection-page :organization :page :person :place :profile
|
||||||
:place :profile :question :read :reject :relationship :remove :service
|
:question :read :reject :relationship :remove :service :tentative-accept
|
||||||
:tentative-accept :tentative-reject :tombstone :travel :undo :update :video
|
:tentative-reject :tombstone :travel :undo :update :video :view
|
||||||
:view
|
|
||||||
;; Slots
|
;; Slots
|
||||||
:@context :type
|
|
||||||
:activity-actor :activity-instrument :activity-object :activity-origin
|
:activity-actor :activity-instrument :activity-object :activity-origin
|
||||||
:activity-result :activity-target
|
:activity-result :activity-target
|
||||||
:collection-current :collection-first :collection-items :collection-last
|
:collection-current :collection-first :collection-items :collection-last
|
||||||
|
@ -61,23 +55,6 @@
|
||||||
(in-package #:activity-servist/activity-vocabulary)
|
(in-package #:activity-servist/activity-vocabulary)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Globals
|
|
||||||
;;; ————————————————————————————————————————
|
|
||||||
(defparameter *ap-packages* (list *package*)
|
|
||||||
"A list of packages in which we should search for AP classes and slot-symbols
|
|
||||||
during JSON parsing. The class-name searched for is simply the value of the JSON
|
|
||||||
object’s “type” key. The package first in the list to export such a symbol
|
|
||||||
is the winner.")
|
|
||||||
|
|
||||||
;; Private, internal variable.
|
|
||||||
(defparameter *@context* nil
|
|
||||||
"Used in YASON:ENCODE to ensure that a single top-level @context can be
|
|
||||||
created where AP objects contain other AP objects in their slots.
|
|
||||||
This variable is overridden locally during encoding (LET), and should never be
|
|
||||||
modified globally (as we expect it to be nil in top-level objects.")
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Macros
|
;;; Macros
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
|
@ -113,42 +90,12 @@ of NAME."
|
||||||
`(defclass ,a (,name) ()))
|
`(defclass ,a (,name) ()))
|
||||||
direct-children)))
|
direct-children)))
|
||||||
|
|
||||||
;; This macro and the following function are related to JSON serialization; see
|
|
||||||
;; the below “JSON serialization” section for other related functions.
|
|
||||||
(defmacro define-yason-encode-slots (class)
|
|
||||||
"Define a YASON:ENCODE-SLOTS method for a CLASS, which simply encodes all of
|
|
||||||
CLASS’es slots with JSON keys based on the camel-cased slot name."
|
|
||||||
(append
|
|
||||||
`(defmethod yason:encode-slots progn ((obj ,class)))
|
|
||||||
(mapcar (yason-encode-slot-function)
|
|
||||||
(class-slots-activity-alist class))))
|
|
||||||
|
|
||||||
(defun yason-encode-slot-function ()
|
|
||||||
"Helper-function for the DEFINE-YASON-ENCODE-SLOTS macro.
|
|
||||||
This returns a function to create a quoted function that should be called for each slot,
|
|
||||||
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)))
|
|
||||||
((eq key 'type) ; Encode type based on class-name or TYPE slot
|
|
||||||
(yason:encode-object-element
|
|
||||||
"type" (or value
|
|
||||||
(class-pretty-name (class-of obj)))))
|
|
||||||
(value
|
|
||||||
(yason:encode-object-element ,(cdr slot-key-pair) value))))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Core types
|
;;; Core types
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
(defclass as-object ()
|
|
||||||
((@context :initform "https://www.w3.org/ns/activitystreams")
|
|
||||||
(type :accessor object-type)))
|
|
||||||
|
|
||||||
;; https://www.w3.org/ns/activitystreams#Object
|
;; https://www.w3.org/ns/activitystreams#Object
|
||||||
(defclass-w-accessors object (as-object)
|
(defclass-w-accessors object (activity-servist/activity-streams:object)
|
||||||
(
|
(
|
||||||
attachment attributed-to audience bcc bto cc content context
|
attachment attributed-to audience bcc bto cc content context
|
||||||
duration end-time generator icon id image in-reply-to location
|
duration end-time generator icon id image in-reply-to location
|
||||||
|
@ -156,7 +103,7 @@ again and again, by YASON:ENCODE-SLOTS."
|
||||||
tag to updated url))
|
tag to updated url))
|
||||||
|
|
||||||
;; https://www.w3.org/ns/activitystreams#Link
|
;; https://www.w3.org/ns/activitystreams#Link
|
||||||
(defclass-w-accessors link (as-object)
|
(defclass-w-accessors link (activity-servist/activity-streams:object)
|
||||||
(height href hreflang media-type name preview rel width))
|
(height href hreflang media-type name preview rel width))
|
||||||
|
|
||||||
;; https://www.w3.org/ns/activitystreams#Activity
|
;; https://www.w3.org/ns/activitystreams#Activity
|
||||||
|
@ -241,175 +188,11 @@ again and again, by YASON:ENCODE-SLOTS."
|
||||||
(mention))
|
(mention))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; JSON parsing
|
|
||||||
;;; ————————————————————————————————————————
|
|
||||||
(defun parse (string)
|
|
||||||
"Parse a string containing JSON into an ActivityPub object."
|
|
||||||
(parse-table (yason:parse string)))
|
|
||||||
|
|
||||||
(defun parse-table (table)
|
|
||||||
"Parse a hash-table corresponding to YASON-parsed JSON into an ActivityPub object."
|
|
||||||
(let* ((class (car (find-registered-classes (param-case (gethash "type" table)))))
|
|
||||||
(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))))
|
|
||||||
obj))
|
|
||||||
|
|
||||||
(defun parse-value (val)
|
|
||||||
"Parse the value of a key found in YASON-parsed JSON.
|
|
||||||
All ActivityPub objects (hash-tables containing “type”) will be parsed into
|
|
||||||
ActivityPub objects; all others will parsed into associative lists."
|
|
||||||
(typecase val
|
|
||||||
(hash-table (maybe-parse-table val))
|
|
||||||
(list (mapcar (lambda (a)
|
|
||||||
(if (hash-table-p a)
|
|
||||||
(maybe-parse-table a)
|
|
||||||
a))
|
|
||||||
val))
|
|
||||||
(t val)))
|
|
||||||
|
|
||||||
(defun maybe-parse-table (table)
|
|
||||||
"If a hash-table seems to be a valid ActivityPub object, attempt parsing it
|
|
||||||
into one. Otherwise, parse it into an associative list."
|
|
||||||
(if (gethash "type" table)
|
|
||||||
(parse-table table)
|
|
||||||
(alexandria:hash-table-alist table)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; JSON serialization
|
|
||||||
;;; ————————————————————————————————————————
|
|
||||||
;; Note-worthy: See the above-defined DEFINE-YASON-ENCODE-SLOTS.
|
|
||||||
(defmethod yason:encode ((obj as-object) &optional (stream *standard-output*))
|
|
||||||
(yason:with-output (stream)
|
|
||||||
(yason:encode-object obj)))
|
|
||||||
|
|
||||||
(defmethod yason:encode-object ((obj as-object))
|
|
||||||
(typecase *@context*
|
|
||||||
(null ; If this is the top-level (non-nested) object, establish a @context.
|
|
||||||
(let ((*@context* 'top-level))
|
|
||||||
(yason:encode-object obj)))
|
|
||||||
(symbol ; In the top-level, encode slots and then @context.
|
|
||||||
(setq *@context* (slot-value obj '@context))
|
|
||||||
(yason:with-object ()
|
|
||||||
(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)))))
|
|
||||||
|
|
||||||
(defun class-slots-activity-alist (class)
|
|
||||||
"Return an associative list containing CLASSes slots’ symbols consed with
|
|
||||||
their sanitized string keys appropriate for ActivityVocabular custom.
|
|
||||||
A class with slots MAP-AWAY and COLLECTION-AGAIN would return
|
|
||||||
((MAP-AWAY . “mapAway”)(COLLECTION-AGAIN . “collectionAgain”))"
|
|
||||||
(alist-mapcdr #'camel-case
|
|
||||||
(class-slots-alist class)))
|
|
||||||
|
|
||||||
(defun merge-@contexts (a b)
|
|
||||||
"Given two @context lists, A and B, merge them into one JSON-LD @context list
|
|
||||||
containing both of their elements."
|
|
||||||
(cond ((equal a b) a)
|
|
||||||
((not b) a)
|
|
||||||
((not a) b)
|
|
||||||
((and (listp a)
|
|
||||||
(find b a :test #'equal))
|
|
||||||
a)
|
|
||||||
(T
|
|
||||||
(merge-lists
|
|
||||||
(if (listp a) a (list a))
|
|
||||||
(if (listp b) b (list b))))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Util
|
|
||||||
;;; ————————————————————————————————————————
|
|
||||||
(defun camel-case (string)
|
|
||||||
"Convert a STRING to camel-casing. That is, casingLikeThis.
|
|
||||||
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
|
|
||||||
character at the start of the string gets erroneously (or at least undesireably,
|
|
||||||
to us) removed."
|
|
||||||
(keep-nonalphanumeric-prefix string
|
|
||||||
(str:camel-case string)))
|
|
||||||
|
|
||||||
(defun param-case (string)
|
|
||||||
"Convert a STRING to param-casing. That is, casing-like-this.
|
|
||||||
Wrapper around STR:PARAM-CASE, working around a bug that a non-alphanumeric
|
|
||||||
character at the start of the string gets erroneously (or at least undesireably,
|
|
||||||
to us) removed."
|
|
||||||
(keep-nonalphanumeric-prefix string
|
|
||||||
(str:param-case string)))
|
|
||||||
(defun camel-case (str)
|
|
||||||
"Convert a STRING to camel-casing.
|
|
||||||
Wrapper around STR:CAMEL-CASE, working around a bug that a non-alphanumeric
|
|
||||||
character at the start of the string gets erroneously (or at least undesireably,
|
|
||||||
to us) removed."
|
|
||||||
(keep-nonalphanumeric-prefix str (str:camel-case str)))
|
|
||||||
|
|
||||||
(defun keep-nonalphanumeric-prefix (str child-str)
|
|
||||||
"This ensures that a CHILD-STR derived from STR has the same nonalphanumeric
|
|
||||||
prefix as STR, as some functions like to remove such prefixes."
|
|
||||||
(if (not (alphanumericp (aref str 0)))
|
|
||||||
(concatenate 'string
|
|
||||||
(string (aref str 0))
|
|
||||||
child-str)
|
|
||||||
child-str))
|
|
||||||
|
|
||||||
(defun class-pretty-name (class)
|
|
||||||
"Return a CLASS’es name in a “pretty” (sentence-capitalized) string."
|
|
||||||
(string-capitalize (symbol-name (class-name class))))
|
|
||||||
|
|
||||||
(defun merge-lists (a b)
|
|
||||||
"Given lists A and B, merge them into one list non-redundantly — all unique
|
|
||||||
items in each will be contained in the resultant list."
|
|
||||||
(append a (remove-if (lambda (item) (find item a :test #'equal)) b)))
|
|
||||||
|
|
||||||
(defun find-registered-symbols (str)
|
|
||||||
"Find all symbols identified by string STR within packages in the
|
|
||||||
*ap-packages* list."
|
|
||||||
(mapcar (lambda (package) (find-symbol (string-upcase str) package))
|
|
||||||
*ap-packages*))
|
|
||||||
|
|
||||||
(defun find-registered-classes (str)
|
|
||||||
"Find all classes identified by string STR within pacakges in the
|
|
||||||
*ap-packages* list."
|
|
||||||
(mapcar (lambda (sym) (find-class sym))
|
|
||||||
(find-registered-symbols str)))
|
|
||||||
|
|
||||||
(defun alist-mapcdr (function alist)
|
|
||||||
"Apply a FUNCTION to all values (cdrs) of an ALIST’s pairs. Returns a new ALIST
|
|
||||||
of the same keys, whose values are the results of FUNCTION."
|
|
||||||
(mapcar
|
|
||||||
(lambda (cell)
|
|
||||||
(cons (car cell)
|
|
||||||
(funcall function (cdr cell))))
|
|
||||||
alist))
|
|
||||||
|
|
||||||
(defun class-slots-alist (class)
|
|
||||||
"Return an associative list of a CLASS’es direct slots (by symbol) matched with
|
|
||||||
their names as strings. For instance, a class with slots MAP-AWAY and
|
|
||||||
COLLECTION-AGAIN would return:
|
|
||||||
((MAP-AWAY . “MAP-AWAY”)(COLLECTION-AGAIN . “COLLECTION-AGAIN”)"
|
|
||||||
(mapcar
|
|
||||||
(lambda (slot)
|
|
||||||
(let ((name (closer-mop:slot-definition-name slot)))
|
|
||||||
(cons name (symbol-name name))))
|
|
||||||
(closer-mop:class-direct-slots class)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; Defining YASON:ENCODE-SLOTS
|
;;; Defining YASON:ENCODE-SLOTS
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
;; On-the-fly define YASON:ENCODE-SLOTS for each of our distinct AP classes.
|
;; On-the-fly define YASON:ENCODE-SLOTS for each of our distinct AP classes.
|
||||||
(mapcar (lambda (class)
|
(as/as:define-class-encoders
|
||||||
(closer-mop:finalize-inheritance class)
|
|
||||||
(eval `(define-yason-encode-slots ,class)))
|
|
||||||
(mapcar #'find-class
|
(mapcar #'find-class
|
||||||
'(as-object object link activity collection collection-page
|
'(object link activity collection collection-page ordered-collection
|
||||||
ordered-collection ordered-collection-page place profile
|
ordered-collection-page place profile relationship tombstone)))
|
||||||
relationship tombstone)))
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
;;;; activity-servist/tests/activity-vocabulary: Testing activity-vocabulary.
|
;;;; activity-servist/tests/activity-streams: Testing activity-streams.
|
||||||
|
|
||||||
;; Copyright © 2024 Jaidyn Levesque <jadedctrl@posteo.at>
|
;; Copyright © 2024 Jaidyn Levesque <jadedctrl@posteo.at>
|
||||||
;;
|
;;
|
||||||
|
@ -15,19 +15,19 @@
|
||||||
;; You should have received a copy of the GNU Affero General Public License
|
;; 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/>.
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(defpackage :activity-servist/tests/activity-vocabulary
|
(defpackage :activity-servist/tests/activity-streams
|
||||||
(:use :cl :lisp-unit2)
|
(:use :cl :lisp-unit2)
|
||||||
(:nicknames "AS/T/AV")
|
(:nicknames "AS/T/AS")
|
||||||
(:export :run :run-with-summary))
|
(:export :run :run-with-summary))
|
||||||
|
|
||||||
(in-package :activity-servist/tests/activity-vocabulary)
|
(in-package :activity-servist/tests/activity-streams)
|
||||||
|
|
||||||
(defun run ()
|
(defun run ()
|
||||||
"Run all ACTIVITY-VOCABULARY tests."
|
"Run all ACTIVITY-STREAMS tests."
|
||||||
(lisp-unit2:run-tests :package :activity-servist/tests/activity-vocabulary))
|
(lisp-unit2:run-tests :package :activity-servist/tests/activity-streams))
|
||||||
|
|
||||||
(defun run-with-summary ()
|
(defun run-with-summary ()
|
||||||
"Run tests with summary for ACTIVITY-VOCABULARY."
|
"Run tests with summary for ACTIVITY-STREAMS."
|
||||||
(lisp-unit2:with-summary()
|
(lisp-unit2:with-summary()
|
||||||
(run)))
|
(run)))
|
||||||
|
|
||||||
|
@ -37,7 +37,7 @@
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
(defmacro relative-pathname (path)
|
(defmacro relative-pathname (path)
|
||||||
"Return an absolute path adding the relative PATH to the system’s path."
|
"Return an absolute path adding the relative PATH to the system’s path."
|
||||||
`(asdf:system-relative-pathname :activity-servist/tests/activity-vocabulary ,path))
|
`(asdf:system-relative-pathname :activity-servist/tests/activity-streams ,path))
|
||||||
|
|
||||||
(defmacro define-json-test (path tags)
|
(defmacro define-json-test (path tags)
|
||||||
"Define a lisp-unit2 test for parsing of the given JSON file.
|
"Define a lisp-unit2 test for parsing of the given JSON file.
|
||||||
|
@ -52,7 +52,7 @@ ensuring they are semantically equivalent. White-space and key order are ignored
|
||||||
(yason:parse
|
(yason:parse
|
||||||
(yason:with-output-to-string* ()
|
(yason:with-output-to-string* ()
|
||||||
(yason:encode-object
|
(yason:encode-object
|
||||||
(as/av:parse ,content)))))))))
|
(as/as:parse ,content)))))))))
|
||||||
|
|
||||||
(defun sort-alist (alist predicate)
|
(defun sort-alist (alist predicate)
|
||||||
"Sort an associative list by its keys."
|
"Sort an associative list by its keys."
|
||||||
|
@ -88,6 +88,6 @@ Any nested hash-tables found as values are also sorted, recursively."
|
||||||
;; Examples are taken from the spec:
|
;; Examples are taken from the spec:
|
||||||
;; https://www.w3.org/TR/activitystreams-vocabulary/
|
;; https://www.w3.org/TR/activitystreams-vocabulary/
|
||||||
(mapcar (lambda (file)
|
(mapcar (lambda (file)
|
||||||
(eval `(define-json-test ,file '(:core))))
|
(eval `(define-json-test ,file '(:activity-vocabulary))))
|
||||||
(uiop:directory-files
|
(uiop:directory-files
|
||||||
(relative-pathname "t/activity-vocabulary/core/")))
|
(relative-pathname "t/activity-streams/activity-vocabulary/")))
|
2
t/t.lisp
2
t/t.lisp
|
@ -25,7 +25,7 @@
|
||||||
(defun run ()
|
(defun run ()
|
||||||
"Run tests from all activity-servist subpackages."
|
"Run tests from all activity-servist subpackages."
|
||||||
(activity-servist/tests/signatures:run)
|
(activity-servist/tests/signatures:run)
|
||||||
(activity-servist/tests/activity-vocabulary:run))
|
(activity-servist/tests/activity-streams:run))
|
||||||
|
|
||||||
(defun run-with-summary ()
|
(defun run-with-summary ()
|
||||||
"Run tests with summary for all activity-servist subpackages."
|
"Run tests with summary for all activity-servist subpackages."
|
||||||
|
|
Ŝarĝante…
Reference in New Issue