Compare commits

..

No commits in common. "f98b5d81a9a0966137ad9dd2c522d71438718f8c" and "86b8d0a5144a95b24292d640122a9877605fd6f3" have entirely different histories.

4 changed files with 143 additions and 176 deletions

View File

@ -17,48 +17,59 @@
(defpackage #:activity-servist/vocab/activity (defpackage #:activity-servist/vocab/activity
(:use #:cl) (:use #:cl)
(:nicknames "AS/V/A" "ACTIVITY-VOCABULARY" "ACTIVITY") (:nicknames "AS/V/A" "ACTIVITY-VOCABULARY")
(:shadow #:block #:delete #:first #:ignore #:last #:listen #:read #:remove) (:shadow #:block #:delete #:ignore #:listen #:read #:remove)
;; 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
;; Classes ;; Classes
:accept :activity :actor :add :announce :application :arrive :article :audio :accept :activity :add :announce :application :arrive :article :audio :block
:block :collection :collection-page :create :delete :dislike :document :collection :collection-page :create :delete :dislike :document :event :flag
:event :flag :follow :group :ignore :image :intransitive-activity :invite :follow :group :ignore :ignore :image :intransitive-activity :invite :join
:join :leave :like :link :listen :mention :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 ;; Accessors
;; Slots/Accessors :activity-actor :activity-instrument :activity-object :activity-origin
:accuracy :actor :altitude :any-of :arrive :attachment :attributed-to :activity-result :activity-target
:audience :bcc :bto :cc :closed :content :context :current :deleted :collection-current :collection-first :collection-items :collection-last
:describes :duration :endpoints :end-time :first :followers :following :collection-total-items
:former-type :generator :height :href :hreflang :icon :image :inbox :collection-page-next :collection-page-part-of :collection-page-prev
:in-reply-to :instrument :items :last :latitude :liked :location :longitude :link-height :link-href :link-hreflang :link-media-type :link-name
:media-type :name :next :object :one-of :ordered-items :origin :outbox :link-preview :link-rel :link-summary :link-width
:part-of :preferred-username :prev :preview :published :radius :rel :object-actor :object-attachment :object-attributed-to :object-audience
:relationship :replies :result :start-index :start-time :streams :subject :object-content :object-context :object-name :object-end-time
:summary :tag :target :to :total-items :units :updated :url :width)) :object-generator :object-icon :object-image :object-in-reply-to
:object-location :object-preview :object-published :object-replies
:object-start-time :object-summary :object-tag :object-updated
:object-url :object-to :object-bto :object-cc :object-bcc
:object-media-type :object-duration
:ordered-collection-page-start-index ordered-collection-ordered-items
:place-accuracy :place-altitude :place-latitude :place-longitude
:place-radius :place-units
:question-all-of :question-closed :question-one-of
:profile-describes
:relationship-object :relationship-relationship :relationship-subject
:tombstone-former-type :tombstone-deleted))
(in-package #:activity-servist/vocab/activity) (in-package #:activity-servist/vocab/activity)
(defmacro define-json-empty-types (superclasses context &rest direct-children) (defmacro define-json-empty-types (superclass context &rest direct-children)
"For each list of DIRECT-CHILDREN, a hollow JSON subtype and CLOS subclass "For each list of DIRECT-CHILDREN, a hollow JSON subtype and CLOS subclass
ofE SUPERCLASSES will be created, with the given JSON-LD context @CONTEXT. of SUPERCLASS will be created, with the given JSON-LD context CONTEXT.
These new subclasses have no slots of its own they will be empty derivatives These new subclasses have no slots of its own they will be empty derivatives
of SUPERCLASSES. of SUPERCLASS.
Items of DIRECT-CHILDREN should be of the form, Items of DIRECT-CHILDREN should be of the form,
(CLASS-NAME typeName Documenation-string describing the subclass.)" (CLASS-NAME typeName Documenation-string describing the subclass.)"
(append (append
'(progn) '(progn)
(mapcar (lambda (subclass-list) (mapcar (lambda (subclass-list)
(let ((class-name (cl:first subclass-list)) (let ((class-name (first subclass-list))
(type-name (second subclass-list)) (type-name (second subclass-list))
(documentation (third subclass-list))) (documentation (third subclass-list)))
`(json-ld:define-json-type (,class-name ,type-name) ,superclasses ,context `(json-ld:define-json-type (,class-name ,type-name) (,superclass) ,context
() ()
(:documentation ,documentation)))) (:documentation ,documentation))))
direct-children))) direct-children)))
@ -155,51 +166,11 @@ The notion of “context” used is intentionally vague. The intended function i
:documentation "Identifies the MIME media type of the value of the content property. If not specified, the content property is assumed to contain text/html content.") :documentation "Identifies the MIME media type of the value of the content property. If not specified, the content property is assumed to contain text/html content.")
(duration (duration
"duration" "duration"
:documentation "When the object describes a time-bound resource, such as an audio or video, a meeting, etc, the duration property indicates the object's approximate duration. The value MUST be expressed as an xsd:duration as defined by [ xmlschema11-2], section 3.3.6 (e.g. a period of 5 seconds is represented as “PT5S”).") :documentation "When the object describes a time-bound resource, such as an audio or video, a meeting, etc, the duration property indicates the object's approximate duration. The value MUST be expressed as an xsd:duration as defined by [ xmlschema11-2], section 3.3.6 (e.g. a period of 5 seconds is represented as “PT5S”)."))
;; Required actor slots
(inbox
"inbox"
:documentation "A reference to an OrderedCollection comprised of all the messages received by the actor.")
(outbox
"outbox"
:documentation "An OrderedCollection comprised of all the messages produced by the actor.")
(following
"following"
:documentation "A link to a collection of the actors that this actor is following.")
(followers
"followers"
:documentation "A link to a collection of the actors that follow this actor.")
;; Optional Actor slots
(liked
"liked"
:documentation "A link to a collection of objects this actor has liked.")
(streams
"streams"
:documentation "A list of supplementary Collections which may be of interest.")
(preferred-username
"preferredUsername"
:documentation "A short username which may be used to refer to the actor, with no uniqueness guarantees.")
(endpoints
"endpoints"
:documentation "A JSON object which maps additional (typically server/domain-wide) endpoints which may be useful either for this actor or someone referencing this actor. This mapping may be nested inside the actor document as the value or may be a link to a JSON-LD document with these properties.
May include the properties proxyUrl, oauthAuthorizationEndpoint, oauthTokenEndpoint, provideClientKey, signClientKey, and sharedInbox.
See the spec for details on these properties: https://www.w3.org/TR/activitypub/#proxyUrl"))
;; Class docstring
(:documentation (:documentation
"Describes an object of any kind. The Object type serves as the base type for most of the other kinds of objects defined in the Activity Vocabulary, including other Core types such as Activity, IntransitiveActivity, Collection and OrderedCollection.")) "Describes an object of any kind. The Object type serves as the base type for most of the other kinds of objects defined in the Activity Vocabulary, including other Core types such as Activity, IntransitiveActivity, Collection and OrderedCollection."))
;; https://www.w3.org/TR/activitypub/#x4-actors
;; A dummy ACTOR class, for convenience sake.
(defclass actor ()
()
(:documentation "A dummy-class that represents an Actor ActivityPub object.
There is, in reality, no Actor supertype in ActivityPub; but it might be useful in practice to treat all Actor-subtypes similarly in some cases, like method definition. Hence the existence of this class."))
;; https://www.w3.org/ns/activitystreams#Link ;; https://www.w3.org/ns/activitystreams#Link
;; “summary” here isnt real! Its not a property Link should have (just ;; “summary” here isnt real! Its not a property Link should have (just
;; looking at Links properties), but its implied by the Mention example. ;; looking at Links properties), but its implied by the Mention example.
@ -332,7 +303,7 @@ In the [HTML5], any string not containing the “space” U+0020, “tab” (U+0
;;; Extended Activity types ;;; Extended Activity types
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(define-json-empty-types (activity) "https://www.w3.org/ns/activitystreams" (define-json-empty-types activity "https://www.w3.org/ns/activitystreams"
(accept "Accept" "Indicates that the actor accepts the object. The target property can be used in certain circumstances to indicate the context into which the object has been accepted.") (accept "Accept" "Indicates that the actor accepts the object. The target property can be used in certain circumstances to indicate the context into which the object has been accepted.")
(add "Add" "Indicates that the actor has added the object to the target. If the target property is not explicitly specified, the target would need to be determined implicitly by context. The origin can be used to identify the context from which the object originated.") (add "Add" "Indicates that the actor has added the object to the target. If the target property is not explicitly specified, the target would need to be determined implicitly by context. The origin can be used to identify the context from which the object originated.")
(create "Create" "Indicates that the actor has created the object.") (create "Create" "Indicates that the actor has created the object.")
@ -410,7 +381,7 @@ Either of the ANY-OF and ONE-OF properties MAY be used to express possible answe
;;; Extended Actor types ;;; Extended Actor types
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(define-json-empty-types (object actor) "https://www.w3.org/ns/activitystreams" (define-json-empty-types object "https://www.w3.org/ns/activitystreams"
(application "Application" "Describes a software application.") (application "Application" "Describes a software application.")
(group "Group" "Represents a formal or informal collective of Actors.") (group "Group" "Represents a formal or informal collective of Actors.")
(organization "Organization" "Represents an organization.") (organization "Organization" "Represents an organization.")
@ -421,14 +392,14 @@ Either of the ANY-OF and ONE-OF properties MAY be used to express possible answe
;;; Extended Object types ;;; Extended Object types
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(define-json-empty-types (object) "https://www.w3.org/ns/activitystreams" (define-json-empty-types object "https://www.w3.org/ns/activitystreams"
(article "Article" "Represents any kind of multi-paragraph written work.") (article "Article" "Represents any kind of multi-paragraph written work.")
(document "Document" "Represents a document of any kind.") (document "Document" "Represents a document of any kind.")
(note "Note" "Represents a short written work typically less than a single paragraph in length.") (note "Note" "Represents a short written work typically less than a single paragraph in length.")
(event "Event" "Represents any kind of event.")) (event "Event" "Represents any kind of event."))
(define-json-empty-types (document) "https://www.w3.org/ns/activitystreams" (define-json-empty-types document "https://www.w3.org/ns/activitystreams"
(audio "Audio" "Represents an audio document of any kind.") (audio "Audio" "Represents an audio document of any kind.")
(image "Image" "An image document of any kind.") (image "Image" "An image document of any kind.")
(video "Video" "Represents a video document of any kind.") (video "Video" "Represents a video document of any kind.")

View File

@ -25,10 +25,12 @@
#:no-@context #:no-@context
;; Globals ;; Globals
#:*default-json-type* #:*default-json-type*
;; Classes ;; Objects
#:object #:json-ld-object
;; Slots/Accessors ;; Accessors
:@context :@id :@type :@etc)) #:json-ld-context #:json-ld-etc #:json-ld-id #:json-ld-type
;; Slots
:@context :@id :@type :.etc))
(in-package #:activity-servist/json-ld) (in-package #:activity-servist/json-ld)
@ -40,7 +42,7 @@
of this type. Should be a string, the IRI corresponding to a registered type. of this type. Should be a string, the IRI corresponding to a registered type.
For example: https://www.w3.org/ns/activitystreams#Object For example: https://www.w3.org/ns/activitystreams#Object
The default value * refers to the base JSON-LD:OBJECT type.") The default value * refers to the base JSON-LD-OBJECT type.")
(defvar *json-types* (make-hash-table :test #'equal) (defvar *json-types* (make-hash-table :test #'equal)
"Stores descriptions of each JSON-type, mapping type-IRI to class-name and property-name to slot-name. "Stores descriptions of each JSON-type, mapping type-IRI to class-name and property-name to slot-name.
@ -60,52 +62,52 @@ Maps URLs to text-content, so we dont have to download the same context again
;;; Base class ;;; Base class
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defclass object () (defclass json-ld-object ()
((@context ((@context
:initform nil :initform nil
:documentation :documentation
"Used as an override for a classes @context during encoding. "Used as an override for a classes @context during encoding.
The method @CONTEXT is how the contents of encoded @context is The method JSON-LD-CONTEXT is how the contents of encoded @context is
determined; to change a classes default/calculated @context, override that determined; to change a classes default/calculated @context, override that
method. This slot is for changing a specific objects @context.") method. This slot is for changing a specific objects @context.")
(@id (@id
:accessor @id :accessor json-ld-id
:documentation :documentation
"Provides the globally unique identifier for an object.") "Provides the globally unique identifier for an object.")
(@type (@type
:accessor @type :accessor json-ld-type
:documentation :documentation
"Identifies the type of an object. Used to determine the corresponding CLOS-object.") "Identifies the type of an object. Used to determine the corresponding CLOS-object.")
(@etc (.etc
:initform nil :initform nil
:accessor @etc :accessor json-ld-etc
:documentation :documentation
"Components of the JSON object which, during parsing, did not match any specific "Components of the JSON object which, during parsing, did not match any specific
slot. This is often filled up in the case of undefined node-types or non-adherent slot. This is often filled up in the case of undefined node-types or non-adherent
object definitions."))) object definitions.")))
(setf (gethash "*" *json-types*) (setf (gethash "*" *json-types*)
'((object) '((json-ld-object)
("@context" @context . "@context") ("@context" @context . "@context")
("@id" @id . "@id") ("@id" @id . "@id")
("@type" @type . "@type"))) ("@type" @type . "@type")))
(defgeneric @context (obj) (defgeneric json-ld-context (obj)
(:documentation (:documentation
"Returns a JSON-LD CLOS objects @context, for use in JSON-encoding of the "Returns a JSON-LD CLOS objects @context, for use in JSON-encoding of the
object. object.
The implementation for the JSON-LD:OBJECT class simply returns the activitystreams The implementation for the JSON-LD-OBJECT class simply returns the activitystreams
URL. URL.
If you would like to change @context on a class-level, override this method. If you would like to change @context on a class-level, override this method.
If you would like to change it on an object-level, set the @CONTEXT slot.")) If you would like to change it on an object-level, set the @CONTEXT slot."))
(defmethod @context ((obj object)) (defmethod json-ld-context ((obj json-ld-object))
(let ((slot-@context (slot-value obj '@context))) (let ((slot-@context (slot-value obj '@context)))
(unless (eq slot-@context 'no-@context) (unless (eq slot-@context 'no-@context)
(or slot-@context (or slot-@context
"https://www.w3.org/ns/activitystreams")))) "https://www.w3.org/ns/activitystreams"))))
(defmethod yason:encode-slots progn ((obj object)) (defmethod yason:encode-slots progn ((obj json-ld-object))
(flatten-contained-contexts obj) (flatten-contained-contexts obj)
;; We only want to encode @context, @id, and @type if the child class doesnt ;; We only want to encode @context, @id, and @type if the child class doesnt
;; have its own alias for them. ;; have its own alias for them.
@ -117,9 +119,9 @@ If you would like to change it on an object-level, set the @CONTEXT slot."))
(no-context-p (aliased-prop-p "@context" type-def)) (no-context-p (aliased-prop-p "@context" type-def))
(no-id-p (aliased-prop-p "@id" type-def)) (no-id-p (aliased-prop-p "@id" type-def))
(no-type-p (aliased-prop-p "@type" type-def)) (no-type-p (aliased-prop-p "@type" type-def))
(context (@context obj)) (context (json-ld-context obj))
(id (and (slot-boundp obj '@id) (@id obj))) (id (and (slot-boundp obj '@id) (json-ld-id obj)))
(type (and (slot-boundp obj '@type) (@type obj)))) (type (and (slot-boundp obj '@type) (json-ld-type obj))))
(when (and context (not no-context-p)) (when (and context (not no-context-p))
(yason:encode-object-element "@context" context)) (yason:encode-object-element "@context" context))
(when (and id (not no-id-p)) (when (and id (not no-id-p))
@ -129,9 +131,9 @@ If you would like to change it on an object-level, set the @CONTEXT slot."))
(mapcar (lambda (alist-cell) (mapcar (lambda (alist-cell)
(yason:encode-object-element (car alist-cell) (yason:encode-object-element (car alist-cell)
(cdr alist-cell))) (cdr alist-cell)))
(@etc obj))) (json-ld-etc obj)))
(defmethod yason:encode ((obj object) &optional (stream *standard-output)) (defmethod yason:encode ((obj json-ld-object) &optional (stream *standard-output))
(yason:with-output (stream) (yason:with-output (stream)
(yason:encode-object obj))) (yason:encode-object obj)))
@ -150,9 +152,9 @@ encoding as @types value. If only the CLOS class-name is provided, @type will
not be encoded for this object. not be encoded for this object.
DIRECT-SUPERCLASSES is a list of JSON-LD CLOS classes, whose slots and context DIRECT-SUPERCLASSES is a list of JSON-LD CLOS classes, whose slots and context
this should inherit. JSON-LD:OBJECT should be somewhere in the hierarchy, in order this should inherit. JSON-LD-OBJECT should be somewhere in the hierarchy, in order
to provide @context, @id, and @type; if no superclasses are provided, to provide @context, @id, and @type; if no superclasses are provided,
JSON-LD:OBJECT is default. JSON-LD-OBJECT is default.
CONTEXT is a context hash-table, parsed from a JSON-LD context by JSON-LD:PARSE CONTEXT is a context hash-table, parsed from a JSON-LD context by JSON-LD:PARSE
or JSON-LD:PARSE-CONTEXT. Any terms defined in this context will be used to or JSON-LD:PARSE-CONTEXT. Any terms defined in this context will be used to
@ -169,7 +171,8 @@ SLOT-OPTIONS are key/value pairs in the format of DEFCLASSes slot-options.
Keywords such as :INITFORM, :DOCUMENTATION, etc. can be used. Keywords such as :INITFORM, :DOCUMENTATION, etc. can be used.
There is one keyword with behavior unlike DEFCLASS, however :ACCESSOR. There is one keyword with behavior unlike DEFCLASS, however :ACCESSOR.
By default, a slot will have an accessor simply named after the slot. By default, a slot will have an accessor named after the class and slot, like
PLACE-RADIUS for the class PLACE and the slot RADIUS.
Set :ACCESSOR to NIL to define no accessor at all. Set :ACCESSOR to NIL to define no accessor at all.
OPTIONS contains ordinary class options, in the format of DEFCLASS (for example, OPTIONS contains ordinary class options, in the format of DEFCLASS (for example,
@ -202,11 +205,11 @@ Here is a brief example partially defining the “Place” type from ActivityStr
;; Now, actually define the class, encoder, etc… ;; Now, actually define the class, encoder, etc…
`(let ((json-class `(let ((json-class
(define-json-clos-class ,names (define-json-clos-class ,names
,(or direct-superclasses `(json-ld:object)) ,(or direct-superclasses `(json-ld-object))
,direct-slots ,direct-slots
,options))) ,options)))
(define-json-type-encoder ,(car names) ,direct-slots) (define-json-type-encoder ,(car names) ,direct-slots)
(register-json-type ',names (or ',direct-superclasses '(json-ld:object)) ',direct-slots ,context) (register-json-type ',names (or ',direct-superclasses '(json-ld-object)) ',direct-slots ,context)
json-class))) json-class)))
(defmacro define-json-clos-class (names direct-superclasses direct-slots options) (defmacro define-json-clos-class (names direct-superclasses direct-slots options)
@ -229,12 +232,12 @@ See DEFINE-JSON-TYPEs docstring for a description of parameters."
"Return DEFCLASS-format slot options from DEFINE-JSON-TYPE-format SLOT-OPTS, "Return DEFCLASS-format slot options from DEFINE-JSON-TYPE-format SLOT-OPTS,
applying default slot-options, etc." applying default slot-options, etc."
(json-type-normalize-slot-options (json-type-normalize-slot-options
(merge-plists (json-type-implicit-slot-options slot-name) (merge-plists (json-type-implicit-slot-options class-name slot-name)
slot-opts))) slot-opts)))
(defun json-type-implicit-slot-options (slot-name) (defun json-type-implicit-slot-options (class-name slot-name)
"Return default property-list slot options for a json-type CLOS class." "Return default property-list slot options for a json-type CLOS class."
(list :accessor (intern (format nil "~A" slot-name)))) (list :accessor (intern (format nil "~A-~A" class-name slot-name))))
(defun json-type-normalize-slot-options (slot-opts) (defun json-type-normalize-slot-options (slot-opts)
"Take property-list slot options from a DEFINE-JSON-TYPE format and massage it "Take property-list slot options from a DEFINE-JSON-TYPE format and massage it
@ -336,8 +339,8 @@ parsed into hash-tables) will be parsed into CLOS objects."
(type (identify-json-type parsed-table ctx)) (type (identify-json-type parsed-table ctx))
(type-def (or (gethash type *json-types*) (type-def (or (gethash type *json-types*)
(gethash *default-json-type* *json-types*))) (gethash *default-json-type* *json-types*)))
(valid-object-p type)) (valid-object (or type (gethash "@id" table))))
(if (or valid-object-p (gethash ".always-object" ctx)) (if (or valid-object (gethash ".always-object" ctx))
(parse-table-into-object parsed-table type-def ctx) (parse-table-into-object parsed-table type-def ctx)
parsed-table)))) parsed-table))))
@ -373,10 +376,10 @@ CTX is the according parsed-context."
(lambda (property value) (lambda (property value)
(let* ((property-def (assoc property type-def :test #'equal)) (let* ((property-def (assoc property type-def :test #'equal))
(slot-name (second property-def)) (slot-name (second property-def))
(etc-value (slot-value obj '@etc))) (etc-value (slot-value obj '.etc)))
(if property-def (if property-def
(setf (slot-value obj slot-name) value) (setf (slot-value obj slot-name) value)
(setf (slot-value obj '@etc) (setf (slot-value obj '.etc)
(append etc-value (append etc-value
(list (cons property value))))))) (list (cons property value)))))))
table) table)
@ -499,8 +502,8 @@ during JSON-encoding with YASON:ENCODE."
(loop for subobj in (cdr (contained-json-objects obj)) (loop for subobj in (cdr (contained-json-objects obj))
do do
(progn (progn
(let ((old-context (@context obj)) (let ((old-context (json-ld-context obj))
(old-subcontext (@context subobj))) (old-subcontext (json-ld-context subobj)))
(when (and old-subcontext (when (and old-subcontext
(not (equal old-context old-subcontext))) (not (equal old-context old-subcontext)))
(setf (slot-value obj '@context) (setf (slot-value obj '@context)
@ -511,7 +514,7 @@ during JSON-encoding with YASON:ENCODE."
(setf (slot-value subobj '@context) 'no-@context)))) (setf (slot-value subobj '@context) 'no-@context))))
(defun json-slot-values (obj) (defun json-slot-values (obj)
"Return the values of all registered slots/properties of a JSON-LD:OBJECT. "Return the values of all registered slots/properties of a JSON-LD-OBJECT.
Unregistered slots that dont get encoded/decoded are ignored." Unregistered slots that dont get encoded/decoded are ignored."
(let* ((type-def (class-json-type-definition (class-name (class-of obj)))) (let* ((type-def (class-json-type-definition (class-name (class-of obj))))
(slot-defs (cdr type-def))) (slot-defs (cdr type-def)))
@ -526,31 +529,31 @@ Unregistered slots that dont get encoded/decoded are ignored."
slot-defs) slot-defs)
(mapcar (lambda (etc-cons) (mapcar (lambda (etc-cons)
(cdr etc-cons)) (cdr etc-cons))
(slot-value obj '@etc)))))) (slot-value obj '.etc))))))
(defun contained-json-objects (item) (defun contained-json-objects (item)
"Given ITEM of arbitrary type, return all JSON-LD:OBJECTs contained within, "Given ITEM of arbitrary type, return all JSON-LD-OBJECTs contained within,
recursively. Lists, hash-tables, and the slots of JSON-LD:OBJECTs are explored." recursively. Lists, hash-tables, and the slots of JSON-LD-OBJECTs are explored."
(typecase item (typecase item
(cons (reduce (cons (reduce
(lambda (a b) (lambda (a b)
(append a b)) (append a b))
(mapcar (lambda (a) (contained-json-objects a)) (mapcar (lambda (a) (contained-json-objects a))
item))) item)))
(hash-table (let ((ret '())) (hash-table (let ((ret '()))
(maphash (maphash
(lambda (k v) (lambda (k v)
(setq ret (setq ret
(append ret (contained-json-objects v)))) (append ret (contained-json-objects v))))
item) item)
ret)) ret))
(object (append (json-ld-object (append
(list item) (list item)
(reduce (reduce
(lambda (b c) (lambda (b c)
(append b c)) (append b c))
(mapcar (lambda (a) (contained-json-objects a)) (mapcar (lambda (a) (contained-json-objects a))
(json-slot-values item))))))) (json-slot-values item)))))))

View File

@ -17,16 +17,7 @@
(defpackage #:activity-servist/vocab/litepub (defpackage #:activity-servist/vocab/litepub
(:use #:cl) (:use #:cl)
(:nicknames "AS/V/LP" "LITEPUB") (:nicknames "AS/V/LP" "LITEPUB"))
(:export
;; Classes
:object
:chat-message :emoji :emoji-react :hashtag :property-value
;; Slots/Accessors
:also-known-as :atom-uri :capabilities :conversation :direct-message-p
:discoverablep :former-representations :invisiblep :list-message
:manually-approves-followers-p :non-anonymous :public-key :quote-uri
:quote-url :sensitivep :value))
(in-package #:activity-servist/vocab/litepub) (in-package #:activity-servist/vocab/litepub)
@ -35,7 +26,7 @@
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defvar *litepub-uri* "https://jam.xwx.moe/schemas/litepub-0.1.jsonld" (defvar *litepub-uri* "https://jam.xwx.moe/schemas/litepub-0.1.jsonld"
"The Litepub flavour we use is nicked directly from Pleroma; there is not a "The Litepub flavour we use is nicked directly from Pleroma; there is not a
canonical URL for it. This URI will be used in encoded LITEPUB:OBJECTs in the canonical URL for it. This URI will be used in encoded LITEPUB-OBJECTs in the
@CONTEXT. @CONTEXT.
Defaults to a copy at jam.xwx.moe because why not? ¯\_()_/¯") Defaults to a copy at jam.xwx.moe because why not? ¯\_()_/¯")
@ -43,61 +34,35 @@ Defaults to a copy at jam.xwx.moe — because why not? ¯\_(ツ)_/¯")
;;; Core types ;;; Core types
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
(defclass object () (defclass litepub-object ()
() ()
(:documentation "The base class used for Litepub objects.")) (:documentation "The base class used for Litepub objects."))
(json-ld:define-json-type (as/v/a:object "Object") (as/jld:object litepub:object) *litepub-uri* (json-ld:define-json-type (as/v/a:object "Object") (as/jld::json-ld-object litepub-object) *litepub-uri*
((atom-uri ((atom-uri
"atomUri" "atomUri"
:documentation "A string containing a URI to an Atom-feed alternative representation of an object. :documentation "A string containing a URI to an Atom-feed alternative representation of an object.
Potentially deprecated/very uncommon.") Potentially deprecated/very uncommon.")
;; https://docs.joinmastodon.org/spec/activitypub/#sensitive ;; https://docs.joinmastodon.org/spec/activitypub/#sensitive
(sensitivep (sensitive
"sensitive" "sensitive"
:documentation "A boolean value, representing whether or not an Objects content is not necessarily generally appropriate. This will often hide the content, to some clients. SUMMARY will often be displayed in place of the content.") :documentation "A boolean value, representing whether or not an Objects content is not necessarily generally appropriate. This will often hide the content, to some clients. SUMMARY will often be displayed in place of the content.")
(non-anonymous (non-anonymous
"nonAnonymous" "nonAnonymous"
:documentation "I had no luck finding what this might mean, to be honest. ¯\_()_/¯ :documentation "I had no luck finding what this might mean, to be honest. ¯\_()_/¯
Likely deprecated/highly uncommon.") Likely deprecated/highly uncommon.")
(direct-message-p (direct-message
"directMessage" "directMessage"
:documentation "A boolean value commonly used to mark a Note as non-public, a direct message to be visible only to those in TO. :documentation "A boolean value commonly used to mark a Note as non-public, a direct message to be visible only to those in TO.
Seemingly may be set in the Activity modifying the Note, or the Note itself.") Seemingly may be set in the Activity modifying the Note, or the Note itself.")
(former-representations (former-representations
"formerRepresentations") "formerRepresentations"))
;; Actor properties
(public-key
"publicKey"
:documentation "Contains an object representing a definition of the Actors public key, used for HTTP signatures.
Generally contains the properties id, owner, publicKeyPem.")
;; https://docs.joinmastodon.org/spec/activitypub/#discoverable
(discoverablep
"discoverable"
:accessor actor-discoverable-p
:documentation "A boolean value reflecting whether or not an Actors profile should be publically discoverable.")
;; https://docs.joinmastodon.org/spec/activitypub/#as
(manually-approves-followers-p
"manuallyApprovesFollowers"
:accessor actor-manually-approves-followers-p
:documentation "A boolean value, communicating whether or not an Actor screens follow-requests.")
;; https://docs.joinmastodon.org/spec/activitypub/#Move
(also-known-as
"alsoKnownAs"
:accessor actor-also-known-as
:documentation "When moving between two accounts, the old account sets this property to the URI of the new account.")
(capabilities
"capabilities"
:accessor actor-capabilities
:documentation "Contains a hash-table of capability-names mapped to a boolean, marking this Actors (servers) support of capability.
One known capabilitity-name is Pleromas acceptsChatMessages."))
(:update 't)) (:update 't))
(json-ld:define-json-type (as/v/a:activity "Activity") (as/v/a:object) *litepub-uri* (json-ld:define-json-type (as/v/a:activity "Activity") (as/v/a:object) *litepub-uri*
(;; https://blog.dereferenced.org/leveraging-json-ld-compound-typing-for-behavioural-hinting-in-activitypub (;; https://blog.dereferenced.org/leveraging-json-ld-compound-typing-for-behavioural-hinting-in-activitypub
(invisiblep (invisible
"invisible" "invisible"
:documentation "A boolean value hinting as to whether or not the result of an Activity should be invisible to the end-user. :documentation "A boolean value hinting as to whether or not the result of an Activity should be invisible to the end-user.
Potentially deprecated/very uncommon.") Potentially deprecated/very uncommon.")
@ -109,7 +74,7 @@ Potentially deprecated/very uncommon.")
;; https://schema.org/PropertyValue ;; https://schema.org/PropertyValue
(json-ld:define-json-type (property-value "PropertyValue") (json-ld:define-json-type (property-value "PropertyValue")
(litepub:object json-ld:object) *litepub-uri* (litepub-object json-ld:json-ld-object) *litepub-uri*
(;; https://schema.org/value (;; https://schema.org/value
(value (value
"value" "value"
@ -138,6 +103,34 @@ The target and origin typically have no defined meaning.")
(:documentation "This activity is similar to Like activity. In addition to standard properties of Like activity, EmojiReact activity MUST have a content property. Reaction content MUST be either a single unicode grapheme, or a shortcode of a custom emoji. If custom emoji is used, EmojiReact activity MUST have a tag property containing a single Emoji object.")) (:documentation "This activity is similar to Like activity. In addition to standard properties of Like activity, EmojiReact activity MUST have a content property. Reaction content MUST be either a single unicode grapheme, or a shortcode of a custom emoji. If custom emoji is used, EmojiReact activity MUST have a tag property containing a single Emoji object."))
;;; Extended Actor types
;;; ————————————————————————————————————————
(json-ld:define-json-type (as/v/a:person "Person") (as/v/a:object) *litepub-uri*
(;; https://docs.joinmastodon.org/spec/activitypub/#discoverable
(public-key
"publicKey"
:documentation "Contains an object representing a definition of the users public key, used for HTTP signatures.
Generally contains the properties id, owner, publicKeyPem.")
(discoverable
"discoverable"
:documentation "A boolean value reflecting whether or not a profile should be publically discoverable.")
;; https://docs.joinmastodon.org/spec/activitypub/#as
(manually-approves-followers
"manuallyApprovesFollowers"
:documentation "A boolean value, communicating whether or not a profile screens follow-requests.")
;; https://docs.joinmastodon.org/spec/activitypub/#Move
(also-known-as
"alsoKnownAs"
:documentation "When moving between two accounts, the old account sets this property to the URI of the new account.")
(capabilities
"capabilities"
:documentation "Contains a hash-table of capability-names mapped to a boolean, marking this Persons (servers) support of capability.
One known capabilitity-name is Pleromas acceptsChatMessages."))
(:documentation "Represents an individual person.")
(:update 't))
;;; Extended Object types ;;; Extended Object types
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
@ -196,6 +189,6 @@ In case of doubt, QUOTE-URL is preferred."))
;;; Extended Link types ;;; Extended Link types
;;; ———————————————————————————————————————— ;;; ————————————————————————————————————————
;; https://docs.joinmastodon.org/spec/activitypub/#Hashtag ;; https://docs.joinmastodon.org/spec/activitypub/#Hashtag
(json-ld:define-json-type (hashtag "Hashtag") (as/v/a:link litepub:object) *litepub-uri* (json-ld:define-json-type (hashtag "Hashtag") (as/v/a:link litepub-object) *litepub-uri*
() ()
(:documentation "Similar to Mentions, a Hashtag is used to link a post to given topics. Should be stored in a TAG slot, and contain NAME (#hashtag) and HREF (link to a servers hashtag listing).")) (:documentation "Similar to Mentions, a Hashtag is used to link a post to given topics. Should be stored in a TAG slot, and contain NAME (#hashtag) and HREF (link to a servers hashtag listing)."))

View File

@ -17,7 +17,7 @@
(defpackage :activity-servist/tests/vocab/activity (defpackage :activity-servist/tests/vocab/activity
(:use :cl :lisp-unit2) (:use :cl :lisp-unit2)
(:nicknames "AS/T/V/A") (:nicknames "AS/T/V/AV")
(:export :run :run-with-summary)) (:export :run :run-with-summary))
(in-package :activity-servist/tests/vocab/activity) (in-package :activity-servist/tests/vocab/activity)