2024-06-12 16:06:17 -05:00
|
|
|
|
;;;; activity-vocabulary: Classes for ActivityVocabulary types.
|
|
|
|
|
|
|
|
|
|
;; 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 #:activitypub-servist/activity-vocabulary
|
|
|
|
|
(:use #:cl)
|
2024-06-12 22:36:13 -05:00
|
|
|
|
(:nicknames "AP-S/AV" "AV")
|
|
|
|
|
(:shadow #:delete #:ignore #:listen #:read #:remove)
|
2024-06-12 21:42:47 -05:00
|
|
|
|
;; One should never USE this package, since some class-names shadow
|
|
|
|
|
;; core Common Lisp symbols! Beware! :P
|
2024-06-12 22:36:13 -05:00
|
|
|
|
(:export
|
2024-06-16 20:58:19 -05:00
|
|
|
|
;; Classes
|
2024-06-12 22:36:13 -05:00
|
|
|
|
:accept :activity :add :announce :application :arrive :article :audio
|
|
|
|
|
:collection :collection-page :create :delete :dislike :document :event :flag
|
|
|
|
|
:follow :group :ignore :ignore :image :intransitive-activity :invite :join
|
|
|
|
|
:leave :like :link :link :listen :move :note :object :offer
|
|
|
|
|
:ordered-collection :ordered-collection-page :organization :page :person
|
|
|
|
|
:place :profile :question :read :reject :relationship :remove :service
|
|
|
|
|
:tentative-accept :tentative-reject :tombstone :travel :undo :update :video
|
2024-06-16 20:58:19 -05:00
|
|
|
|
:view
|
|
|
|
|
;; Slots
|
|
|
|
|
:activity-actor :activity-instrument :activity-object :activity-origin
|
|
|
|
|
:activity-result :activity-target
|
|
|
|
|
:collection-current :collection-first :collection-items :collection-last
|
|
|
|
|
:collection-total-items
|
|
|
|
|
:collection-page-next :collection-page-part-of :collection-page-prev
|
|
|
|
|
:link-height :link-href :link-hreflang :link-media-type :link-name
|
|
|
|
|
:link-preview :link-rel :link-width
|
|
|
|
|
:object-attachment :object-attributed-to :object-audience :object-bcc
|
|
|
|
|
:object-bto :object-cc :object-content :object-context :object-duration
|
|
|
|
|
:object-end-time :object-generator :object-icon :object-image
|
|
|
|
|
:object-in-reply-to :object-location :object-media-type :object-name
|
|
|
|
|
:object-preview :object-published :object-replies :object-start-time
|
|
|
|
|
:object-summary :object-tag :object-to :object-updated :object-url
|
|
|
|
|
:ordered-collection-page-start-index
|
|
|
|
|
:place-accuracy :place-altitude :place-latitude :place-longitude
|
|
|
|
|
:place-radius :place-units
|
|
|
|
|
:profile-describes
|
|
|
|
|
:relationship-object :relationship-relationship :relationship-subject
|
|
|
|
|
:tombstone-former-type :tombstone-deleted))
|
2024-06-12 16:06:17 -05:00
|
|
|
|
|
|
|
|
|
(in-package #:activitypub-servist/activity-vocabulary)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Macros
|
|
|
|
|
;;; ————————————————————————————————————————
|
|
|
|
|
(defmacro defclass-w-accessors (name direct-superclasses slots &rest options)
|
2024-06-12 21:42:47 -05:00
|
|
|
|
"Identical to DEFCLASS, but with one convenience: A slot definition, if being
|
|
|
|
|
simply a symbol, will default to a slot with an accessor and init-arg named after the
|
|
|
|
|
symbol. The init-arg will be “:symbol”, and the accessor will be “classname-symbol”.
|
|
|
|
|
For instance,
|
|
|
|
|
|
|
|
|
|
(defclass-w-accessors PERSON () (AGE
|
|
|
|
|
HEIGHT
|
|
|
|
|
(NAME :INIT-FORM “Unknown”)))
|
|
|
|
|
```
|
|
|
|
|
is equivalent to
|
|
|
|
|
```
|
|
|
|
|
(defclass PERSON () ((AGE :INIT-ARG :AGE :ACCESSOR PERSON-AGE)
|
|
|
|
|
(HEIGHT :INIT-ARG :HEIGHT :ACCESSOR PERSON-HEIGHT)
|
|
|
|
|
(NAME :INIT-FORM “Unknown”)))
|
|
|
|
|
```"
|
2024-06-12 16:06:17 -05:00
|
|
|
|
`(defclass ,name ,direct-superclasses
|
|
|
|
|
,(mapcar
|
|
|
|
|
(lambda (slot)
|
|
|
|
|
(typecase slot
|
|
|
|
|
(list slot)
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(t (list slot :accessor (intern (format nil "~A-~A" name slot))
|
2024-06-16 20:56:45 -05:00
|
|
|
|
:initarg (intern (symbol-name slot) "KEYWORD")
|
|
|
|
|
:initform nil))))
|
2024-06-12 16:06:17 -05:00
|
|
|
|
slots)
|
|
|
|
|
,@options))
|
|
|
|
|
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defmacro defclass-empty-children (name direct-children)
|
|
|
|
|
"For each name in the list DIRECT-CHILDREN, a subclass of NAME will be created.
|
|
|
|
|
These new subclasses have no slots of its own — they will be empty derivatives
|
|
|
|
|
of NAME."
|
|
|
|
|
(append
|
|
|
|
|
'(progn)
|
|
|
|
|
(mapcar (lambda (a)
|
|
|
|
|
`(defclass ,a (,name) ()))
|
|
|
|
|
direct-children)))
|
|
|
|
|
|
2024-06-16 20:51:57 -05:00
|
|
|
|
(defmacro define-yason-encode-slots-to-camel-cased-keys (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 (lambda (slot-key-pair)
|
|
|
|
|
`(yason:encode-object-element ,(cdr slot-key-pair)
|
|
|
|
|
(slot-value obj ',(car slot-key-pair))))
|
|
|
|
|
(class-slots-to-camel-cased-strings-alist class))))
|
|
|
|
|
|
2024-06-12 16:06:17 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Core types
|
|
|
|
|
;;; ————————————————————————————————————————
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Object
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass-w-accessors object ()
|
2024-06-12 16:06:17 -05:00
|
|
|
|
(
|
|
|
|
|
attachment attributed-to audience bcc bto cc content context
|
|
|
|
|
duration end-time generator icon image in-reply-to location
|
|
|
|
|
media-type name preview published replies start-time summary
|
2024-06-16 20:56:45 -05:00
|
|
|
|
tag to updated url
|
|
|
|
|
(@context :initform "https://www.w3.org/ns/activitystreams")))
|
2024-06-16 20:51:57 -05:00
|
|
|
|
|
2024-06-12 16:06:17 -05:00
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Link
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass-w-accessors link ()
|
2024-06-12 16:06:17 -05:00
|
|
|
|
(height href hreflang media-type name preview rel width))
|
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Activity
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass-w-accessors activity (object)
|
2024-06-12 16:06:17 -05:00
|
|
|
|
(actor instrument object origin result target))
|
|
|
|
|
|
|
|
|
|
;; Should be ordinary Activity, sans `object`.
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#IntransitiveActivity
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass intransitive-activity (activity) ())
|
2024-06-12 16:06:17 -05:00
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Collection
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass-w-accessors collection (object)
|
2024-06-12 16:06:17 -05:00
|
|
|
|
(current first items last total-items))
|
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#OrderedCollection
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass ordered-collection (collection) ())
|
2024-06-12 16:06:17 -05:00
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#CollectionPage
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass-w-accessors collection-page (collection)
|
2024-06-16 20:51:57 -05:00
|
|
|
|
(next part-of prev))
|
2024-06-12 16:06:17 -05:00
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#OrderedCollectionPage
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass-w-accessors ordered-collection-page (collection-page)
|
|
|
|
|
(start-index))
|
2024-06-12 16:06:17 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Extended Activity types
|
|
|
|
|
;;; ————————————————————————————————————————
|
2024-06-12 21:42:47 -05:00
|
|
|
|
(defclass-empty-children activity
|
|
|
|
|
(accept add announce create delete dislike flag follow ignore join leave
|
|
|
|
|
like listen move offer read reject remove travel undo update view))
|
|
|
|
|
|
|
|
|
|
(defclass arrive (intransitive-activity) ())
|
|
|
|
|
(defclass ignore (block) ())
|
|
|
|
|
(defclass invite (offer) ())
|
|
|
|
|
(defclass question (intransitive-activity) ())
|
|
|
|
|
(defclass tentative-accept (accept) ())
|
|
|
|
|
(defclass tentative-reject (reject) ())
|
2024-06-12 22:21:48 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Extended Actor types
|
|
|
|
|
;;; ————————————————————————————————————————
|
2024-06-16 20:56:45 -05:00
|
|
|
|
(defclass-empty-children object
|
2024-06-12 22:21:48 -05:00
|
|
|
|
(application group organization person service))
|
2024-06-12 22:29:27 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Extended Object types
|
|
|
|
|
;;; ————————————————————————————————————————
|
|
|
|
|
(defclass-empty-children object
|
|
|
|
|
(article document event note))
|
|
|
|
|
|
|
|
|
|
(defclass-empty-children document
|
|
|
|
|
(audio image page video))
|
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Place
|
|
|
|
|
(defclass-w-accessors place (object)
|
|
|
|
|
(accuracy altitude latitude longitude radius units))
|
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Profile
|
|
|
|
|
(defclass-w-accessors profile (object)
|
|
|
|
|
(describes))
|
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Relationship
|
|
|
|
|
(defclass-w-accessors relationship (object)
|
|
|
|
|
(object relationship subject))
|
|
|
|
|
|
|
|
|
|
;; https://www.w3.org/ns/activitystreams#Tombstone
|
|
|
|
|
(defclass-w-accessors tombstone (object)
|
|
|
|
|
(former-type deleted))
|
2024-06-12 22:30:01 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Extended Link types
|
|
|
|
|
;;; ————————————————————————————————————————
|
|
|
|
|
(defclass-empty-children link
|
|
|
|
|
(mention))
|
2024-06-16 20:51:57 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; JSON serialization
|
|
|
|
|
;;; ————————————————————————————————————————
|
2024-06-16 21:10:36 -05:00
|
|
|
|
;; Ensure all classes have their slots’ encodings defined with YASON.
|
|
|
|
|
(mapcar (lambda (class)
|
|
|
|
|
(closer-mop:finalize-inheritance class)
|
|
|
|
|
(eval `(define-yason-encode-slots-to-camel-cased-keys ,class)))
|
|
|
|
|
(mapcar #'find-class
|
|
|
|
|
'(object link activity collection collection-page
|
|
|
|
|
ordered-collection-page place profile relationship tombstone)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Util
|
|
|
|
|
;;; ————————————————————————————————————————
|
2024-06-16 20:51:57 -05:00
|
|
|
|
(defun class-slots-to-camel-cased-strings-alist (class)
|
|
|
|
|
"Return an associative list of a CLASS’es direct slots (by symbol) matched with
|
|
|
|
|
their names in camel-case format."
|
|
|
|
|
(mapcar
|
|
|
|
|
(lambda (slot)
|
|
|
|
|
(let ((name (closer-mop:slot-definition-name slot)))
|
2024-06-16 21:10:36 -05:00
|
|
|
|
(cons name (camel-case (symbol-name name)))))
|
2024-06-16 20:51:57 -05:00
|
|
|
|
(closer-mop:class-direct-slots class)))
|
|
|
|
|
|
2024-06-16 21:10:36 -05:00
|
|
|
|
(defun camel-case (string)
|
|
|
|
|
"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."
|
|
|
|
|
(if (not (alphanumericp (aref string 0)))
|
|
|
|
|
(concatenate 'string
|
|
|
|
|
(string (aref string 0))
|
|
|
|
|
(str:camel-case string))
|
|
|
|
|
(str:camel-case string)))
|