Fix encoding of aliased @ID, @CONTEXT, and @TYPE

Previously, aliasing them (like ActivityVocab’s
ID→@ID) would cause them to get encoded twice.

activity-servist.asd

@@ -26,6 +26,17 @@
   :components ((:file "src/activity-vocabulary")))
 
 
+(asdf:defsystem "activity-servist/litepub"
+  :version "0.0"
+  :license "AGPLv3"
+  :description "A-S subpackage providing an expanded vocabulary."
+  :author "Jaidyn Ann <jadedctrl@posteo.at>"
+  :homepage "https://hak.xwx.moe/jadedctrl/activity-servist"
+
+  :depends-on ("activity-servist/activity-vocabulary")
+  :components ((:file "src/litepub")))
+
+
 (asdf:defsystem "activity-servist/json-ld"
   :version "0.0"
   :license "AGPLv3"

src/activity-vocabulary.lisp

@@ -81,10 +81,10 @@ Items of DIRECT-CHILDREN should be of the form,
 ;; https://www.w3.org/ns/activitystreams#Object
 ;; The root of all evil in the world.
 (json-ld::define-json-type (object "Object") () "https://www.w3.org/ns/activitystreams"
-  ((@id
+  ((json-ld:@id
     "id"
     :documentation "Provides the globally unique identifier for an Object.")
-   (@type
+   (json-ld:@type
     "type"
     :documentation "Identifies the Object type. Multiple values may be specified.")
    (attachment

src/json-ld.lisp

@@ -25,6 +25,8 @@
    #:no-@context
    ;; Globals
    #:*default-json-type*
+   ;; Objects
+   #:json-ld-object
    ;; Accessors
    #:json-ld-context #:json-ld-etc #:json-ld-id #:json-ld-type
    ;; Slots
@@ -59,12 +61,10 @@ The method JSON-LD-CONTEXT is how the contents of encoded @context is
 determined; to change a class’es default/calculated @context, override that
 method. This slot is for changing a specific object’s @context.")
    (@id
-    :initform nil
     :accessor json-ld-id
     :documentation
     "Provides the globally unique identifier for an object.")
    (@type
-    :initform nil
     :accessor json-ld-type
     :documentation
     "Identifies the type of an object. Used to determine the corresponding CLOS-object.")
@@ -99,15 +99,25 @@ If you would like to change it on an object-level, set the @CONTEXT slot."))
 
 (defmethod yason:encode-slots progn ((obj json-ld-object))
   (flatten-contained-contexts obj)
-  (let ((context (json-ld-context obj))
+  ;; We only want to encode @context, @id, and @type if the child class doesn’t
-        (id      (json-ld-id obj))
+  ;; have its own alias for them.
-        (type    (json-ld-type obj)))
+  (flet ((aliased-prop-p (property-name type-def)
-   (when context
+           (not (equal property-name
-     (yason:encode-object-element "@context" (json-ld-context obj)))
+                       (cddr (assoc property-name type-def :test #'equal))))))
-   (when id
+    (let* ((class-name   (class-name (class-of obj)))
-     (yason:encode-object-element "@id"      (json-ld-id obj)))
+           (type-def     (cdr (class-json-type-definition class-name)))
-   (when type
+           (no-context-p (aliased-prop-p "@context" type-def))
-     (yason:encode-object-element "@type"    (json-ld-type obj))))
+           (no-id-p      (aliased-prop-p "@id" type-def))
+           (no-type-p    (aliased-prop-p "@type" type-def))
+           (context      (json-ld-context obj))
+           (id           (and (slot-boundp obj '@id)   (json-ld-id obj)))
+           (type         (and (slot-boundp obj '@type) (json-ld-type obj))))
+      (when (and context (not no-context-p))
+        (yason:encode-object-element "@context" context))
+      (when (and id (not no-id-p))
+        (yason:encode-object-element "@id"      id))
+      (when (and type (not no-type-p))
+        (yason:encode-object-element "@type"    type))))
   (mapcar (lambda (alist-cell)
             (yason:encode-object-element (car alist-cell)
                                          (cdr alist-cell)))
@@ -176,15 +186,12 @@ Here is a brief example partially defining the “Place” type from ActivityStr
                 :documentation “The longitude of a place.”)))"
   ;; If the definition is an :UPDATE, remove that from OPTIONS and merge the old
   ;; slots with the new.
-  (let ((direct-slots (if (assoc :update options)
+  (let ((direct-slots
+          (if (assoc :update options)
               (progn (setf options (remove-from-alist :update options))
                      (merge-alists direct-slots
-                                               (gethash (car names) *class-defs*)
+                                   (gethash (car names) *class-defs*) 't))
-                                               't))
               direct-slots)))
-    ;; Save the direct-slots, in case of future :UPDATEs.
-    (setf (gethash (car names) *class-defs*) direct-slots)
-
     ;; Now, actually define the class, encoder, etc…
     `(let ((json-class
              (define-json-clos-class ,names
@@ -258,6 +265,10 @@ corresponding CLOS class) of a node."
   (let* ((ctx       (parse-context context))
          (type-iri  (getf (gethash (cadr names) ctx) :id))
          (type-name (or type-iri (cadr names))))
+    ;; Save the type’s direct-slots, in case of future :UPDATEs.
+    (setf (gethash (car names) *class-defs*)
+          direct-slots)
+    ;; Now actually save the JSON-type.
     (setf (gethash type-name *json-types*)
           (json-type-registry-list names direct-superclasses ctx direct-slots))))
 
@@ -266,6 +277,7 @@ corresponding CLOS class) of a node."
   (TYPE-IRI (PROPERTY-NAME SLOT-NAME) ⋯ (PROPERTY-NAME SLOT-NAME))
 … where TYPE-IRI is the (hopefully) fully-resolved IRI form of the node-type’s
 name, though it might be unresolved if context was unprovided or lacking."
+  (remove-duplicates
    (append
     ;; The class-name and type-name.
     (list (cons (car names) (cadr names)))
@@ -287,10 +299,14 @@ name, though it might be unresolved if context was unprovided or lacking."
                       (let* ((type-def (class-json-type-definition class-name)))
                         (when type-def
                           (cdr type-def))))
-                   direct-superclasses))))
+                    direct-superclasses)))
+   :test (lambda (a b) (equal (car a) (car b)))
+   :from-end 't))
 
-(defun parse (str)
+(defun parse (str &optional always-object)
-  "Parse the JSON-LD document contained in STR."
+  "Parse the JSON-LD document contained in STR.
+If ALWAYS-OBJECT is non-nil, even invalid JSON-LD objects (which would normally be
+parsed into hash-tables) will be parsed into CLOS objects."
   (let ((ctx     (make-hash-table :test #'equal)) ; Parsed context
         (parsed (yason:parse str)))
     (values (parse-item parsed ctx)

src/litepub.lisp

@@ -0,0 +1,190 @@
+;;;; litepub: Common ActivityPub JSON-types, borrowed from Pleroma
+
+;; 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/litepub
+  (:use #:cl)
+  (:nicknames "AS/LP" "LITEPUB"))
+
+(in-package #:activity-servist/litepub)
+
+
+;;; Globals
+;;; ————————————————————————————————————————
+(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
+canonical URL for it. This URI will be used in encoded LITEPUB-OBJECTs in the
+@CONTEXT.
+Defaults to a copy at jam.xwx.moe — because why not? ¯\_(ツ)_/¯")
+
+
+
+;;; Core types
+;;; ————————————————————————————————————————
+(defclass litepub-object ()
+  ()
+  (:documentation "The base class used for Litepub objects."))
+
+(json-ld:define-json-type (as/av:object "Object") (as/jld::json-ld-object litepub-object) *litepub-uri*
+  ((atom-uri
+    "atomUri"
+    :documentation "A string containing a URI to an Atom-feed alternative representation of an object.
+Potentially deprecated/very uncommon.")
+   ;; https://docs.joinmastodon.org/spec/activitypub/#sensitive
+   (sensitive
+    "sensitive"
+    :documentation "A boolean value, representing whether or not an Object’s 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
+    "nonAnonymous"
+    :documentation "I had no luck finding what this might mean, to be honest. ¯\_(ツ)_/¯
+Likely deprecated/highly uncommon.")
+   (direct-message
+    "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.
+Seemingly may be set in the Activity modifying the Note, or the Note itself.")
+   (former-representations
+    "formerRepresentations"))
+  (:update 't))
+
+
+(json-ld:define-json-type (as/av:activity "Activity") (as/av:object) *litepub-uri*
+  (;; https://blog.dereferenced.org/leveraging-json-ld-compound-typing-for-behavioural-hinting-in-activitypub
+   (invisible
+    "invisible"
+    :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.")
+   (list-message
+    "list-message"))
+  (:documentation "An Activity is a subtype of Object that describes some form of action that may happen, is currently happening, or has already happened. The Activity type itself serves as an abstract base type for all types of activities. It is important to note that the Activity type itself does not carry any specific semantics about the kind of action being taken.")
+  (:update 't))
+
+
+;; https://schema.org/PropertyValue
+(json-ld:define-json-type (property-value "PropertyValue")
+    (litepub-object json-ld:json-ld-object) *litepub-uri*
+  (;; https://schema.org/value
+   (value
+    "value"
+    :documentation "The value of a property value node."))
+  (:documentation
+   "Commonly used to store custom metadata on a Person, stored in its ATTACHMENT slot."))
+
+
+
+;;; Extended Activity types
+;;; ————————————————————————————————————————
+(json-ld:define-json-type (as/av:update "Update") (as/av:activity) *litepub-uri*
+  (;; https://ostatus.github.io/spec/OStatus%201.0%20Draft%202.html#rfc.section.6
+   (conversation
+    "conversation"
+    :documentation "When an update is part of a distributed conversation, this is the URI of that conversation.
+Likely deprecated/highly uncommon."))
+  (:documentation "Indicates that the actor has updated the object. Note, however, that this vocabulary does not define a mechanism for describing the actual set of modifications made to object.
+The target and origin typically have no defined meaning.")
+  (:update 't))
+
+
+;; https://codeberg.org/fediverse/fep/src/branch/main/fep/c0e0/fep-c0e0.md
+(json-ld:define-json-type (emoji-react "EmojiReact") (as/av:like) *litepub-uri*
+  ()
+  (: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/av:person "Person") (as/av:object) *litepub-uri*
+  (;; https://docs.joinmastodon.org/spec/activitypub/#discoverable
+   (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 Person’s (server’s) support of capability.
+One known capabilitity-name is Pleroma’s “acceptsChatMessages”."))
+  (:documentation "Represents an individual person.")
+  (:update 't))
+
+
+
+;;; Extended Object types
+;;; ————————————————————————————————————————
+;; https://docs.joinmastodon.org/spec/activitypub/#Emoji
+(json-ld:define-json-type (emoji "Emoji") (as/av:object) *litepub-uri*
+  ()
+  (:documentation "Represents a custom-emoji, with a shortcode (NAME), ID, and ICON (containing MEDIA-TYPE and URL)."))
+
+
+(json-ld:define-json-type (as/av:note "Note") (as/av:object) *litepub-uri*
+  (;; https://misskey-hub.net/ns#_misskey_quote
+   (quote-url
+    "quoteUrl"
+    :accessor nil
+    :documentation "Signifies that this Note is “quoting” another Note. Its value is another Note’s ID.
+Effectively equivalent to QUOTE-URI.
+One of QUOTE-URL (as:quoteUrl) or QUOTE-URI (fedibird:quoteUri) is to be deprecated, and the other ought be preferred.
+It is, however, unclear which one will win out in the end. The implementer prefers QUOTE-URL.")
+   ;; https://misskey-hub.net/ns#_misskey_quote
+   (quote-uri
+    "quoteUri"
+    :accessor nil
+    :documentation "Signifies that this Note is “quoting” another Note. Its value is another Note’s ID.
+Effectively equivalent to QUOTE-URL.
+One of QUOTE-URL (as:quoteUrl) or QUOTE-URI (fedibird:quoteUri) is to be deprecated, and the other ought be preferred.
+It is, however, unclear which one will win out in the end. The implementer prefers QUOTE-URL."))
+  (:documentation "Represents a short written work typically less than a single paragraph in length.")
+  (:update 't))
+
+
+;; https://docs-develop.pleroma.social/backend/development/ap_extensions/#chatmessages
+(json-ld:define-json-type (chat-message "ChatMessage") (as/av:note) *litepub-uri*
+  ()
+  (:documentation "Represents a private and one-on-one chat-message.
+Similar to Notes in creation and use, but TO may contain only one recipient.
+Potentially very uncommon — it is used by at least Pleroma."))
+
+
+(defgeneric note-quote-url (obj)
+  (:documentation "Accessor for a NOTE’s “quote-URL”, as used for quote-posts in Pleroma, Misskey, etc.
+Will set/get the value of either QUOTE-URL or QUOTE-URI, depending on which is currently in use.
+In case of doubt, QUOTE-URL is preferred."))
+
+(defmethod note-quote-url ((obj as/av:note))
+  (or (and (slot-boundp note 'quote-url) (slot-value note 'quote-url))
+      (and (slot-boundp note 'quote-uri) (slot-value note 'quote-uri))))
+
+(defgeneric (setf note-quote-url) (obj value))
+(defmethod (setf note-quote-url) ((obj as/av:note) value)
+  (if (slot-boundp note 'quote-uri)
+      (setf (slot-value note 'quote-uri) value)
+      (setf (slot-value note 'quote-url) value)))
+
+
+
+;;; Extended Link types
+;;; ————————————————————————————————————————
+;; https://docs.joinmastodon.org/spec/activitypub/#Hashtag
+(json-ld:define-json-type (hashtag "Hashtag") (as/av: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 server’s hashtag listing)."))