src/activity-vocabulary.lisp

@@ -22,7 +22,6 @@
   ;; One should never USE this package, since some class-names shadow
   ;; core Common Lisp symbols! Beware! :P
   (:export
-   ;; Classes
    :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
@@ -30,27 +29,8 @@
    :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
-   :view
+   :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))
 
 (in-package #:activitypub-servist/activity-vocabulary)
 
@@ -79,8 +59,7 @@ is equivalent to
          (typecase slot
            (list slot)
            (t (list slot :accessor (intern (format nil "~A-~A" name slot))
-                         :initarg  (intern (symbol-name slot) "KEYWORD")
+                         :initarg  (intern (symbol-name slot) "KEYWORD")))))
-                         :initform nil))))
        slots)
      ,@options))
 
@@ -94,17 +73,6 @@ of NAME."
              `(defclass ,a (,name) ()))
            direct-children)))
 
-(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)
-             `(let ((value (slot-value obj ',(car slot-key-pair))))
-                (when value
-                  (yason:encode-object-element ,(cdr slot-key-pair) value))))
-      (class-slots-to-camel-cased-strings-alist class))))
-
 
 
 ;;; Core types
@@ -113,14 +81,9 @@ CLASS’es slots with JSON keys based on the camel-cased slot name."
 (defclass-w-accessors object ()
   (
    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 image in-reply-to location
    media-type name preview published replies start-time summary
-   tag to updated url
+   tag to updated url))
-   (@context :initform "https://www.w3.org/ns/activitystreams")))
-
-(defmethod yason:encode ((obj object) &optional (stream *standard-output*))
-  (yason:with-output (stream)
-    (yason:encode-object obj)))
 
 ;; https://www.w3.org/ns/activitystreams#Link
 (defclass-w-accessors link ()
@@ -168,7 +131,7 @@ CLASS’es slots with JSON keys based on the camel-cased slot name."
 
 ;;; Extended Actor types
 ;;; ————————————————————————————————————————
-(defclass-empty-children object
+(defclass-empty-children actor
   (application group organization person service))
 
 
@@ -203,39 +166,3 @@ CLASS’es slots with JSON keys based on the camel-cased slot name."
 ;;; ————————————————————————————————————————
 (defclass-empty-children link
   (mention))
-
-
-
-;;; JSON serialization
-;;; ————————————————————————————————————————
-;; 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
-;;; ————————————————————————————————————————
-(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)))
-      (cons name (camel-case (symbol-name name)))))
-   (closer-mop:class-direct-slots class)))
-
-(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)))