[Cl-perec-devel] JSON serialization

[Mihai Bazon]

(resending to the list as well)

Maciej Katafiasz <mathrick at gmail.com> wrote:
> On Sat, Sep 19, 2009 at 2:11 PM, Mihai Bazon <mihai at bazon.net> wrote:
> > (declare (ignorable (last-email-from 'mishoo)))   ;-)
> >
> > My mistake, it's doable without touching perec...  I should take more
> > MOP for breakfast before posting to the list.
> 
> Which shouldn't be taken to mean you shouldn't post your results regardless :)


Well, I thought it's a bit lengthy and maybe not interesting for the wizards
on this list and besides, I'm still not very satisfied with the outcome, but
here goes.


Metaclass
=========

I defined a metaclass that will be used for my persistent objects instead of
the default cl-perec:persistent-class.  It contains a json-props slot that
collects JSONizable properties as classes using this metaclass are defined.
It's metaclass in turn must be computed-class:computed-class, in order to be
compatible with cl-perec:persistent-class.

    (defparameter *json-serialization* 0)

    (defclass dlweb.db.metaclass (persistent-class)
      ((json-props :initform nil :type list :accessor json-props))
      (:metaclass computed-class:computed-class))

    ;; called by CLOS when a class using :metaclass dlweb.db.metaclass is
    ;; (re)defined
    (defmethod shared-initialize :after ((class dlweb.db.metaclass) slot-names
                                         &rest initargs &key direct-slots)
      (declare (ignore initargs slot-names))
      ;; (format t "~A~%~A~%~%" slot-names initargs)
      (loop
         :for slot :in direct-slots
         :for name = (getf slot :name)
         :for json = (getf slot :json 0)
         :when (and json (not (getf slot :instance)))
         :do
         (setf (getf (json-props class) name) json)))

Shared-initialize walks through direct-slots (unfortunately I couldn't
figure out how to cover inherited slots as well) and looks for a "json"
property.  If not found, the default value is zero (always serializable).
Unless this property is nil, the slot and the value of :json is collected in
json-props.

  [ this property specifies the "weight" of the slot for JSON encoding.  The
  default (zero) means very light and is always serialized, while heavier
  props are controlled by *json-serialization*; see encode-json below ]

In order to allow a :json keyword on slot definitions without writing loads
of code to define my own slot classes etc. I had to do the following:

    (pushnew :json defclass-star:*allowed-slot-definition-properties*)

Unfortunately, this property can only be accessed in shared-initialize -- it
doesn't really exist in slot objects.  But it does the job for now.


Defining serializable objects
=============================

I defined some wrappers around defpclass* and defassociation*:

    (defmacro my-defpclass (name &body args)
      `(pushnew (defpclass* ,name
                    , at args
                  (:metaclass dlweb.db.metaclass))
                *dlweb-persistent-classes*))

    (defmacro my-def-association (&body args)
      `(pushnew (prc::find-association (defassociation* , at args))
                *dlweb-persistent-classes*))

  [ Note one small inconsistency here, defpclass* returns a class object,
  while defassociation* returns an association name instead of the object
  itself, so I had to call find-association ]

They automatically add my :metaclass to class definitions and push the newly
created classes in a *dlweb-persistent-classes* variable, which I'll use
next to deploy the schema into the database:

    (defparameter *dlweb-persistent-classes* nil)

    (defun db-deploy-schema ()
      (mapc #'prc::export-to-rdbms (reverse *dlweb-persistent-classes*)))


Base class for serializable objects
===================================

I'm using the following class as the base class for all serializable
objects.  It does two things:

1. maintain a version number for all objects (edition-of object).  It is
   incremented automagically when an object is saved to DB using a
   "before-committing-instance" trigger

2. provide an encode-json method that walks through the json-props list and
   builds a JSON representation of the object.

    (my-defpclass db-versioned-object ()
      ((edition 0 :type integer-32)))

    (defmethod before-committing-instance ((transaction transaction-mixin)
                                           (-self- db-versioned-object)
                                           event)
      (declare (ignore transaction))
      (when (eq event :modified)
        (incf (edition-of -self-)))
      (call-next-method))

    (defun find-slot (class name)
      (when (symbolp class)
        (setq class (find-class class)))
      (find-if #'(lambda(sl)
                   (eq (slot-definition-name sl) name))
               (class-slots class)))

    ;; maximum weight allowed for serialization
    (defparameter *json-serialization* 0)

    ;; this one is ugly, should clean it up
    (defmethod encode-json ((object db-versioned-object) &optional stream)
      (let ((props
             (loop
                :for (name weight) :on (json-props (class-of object)) :by #'cddr
                :when (<= weight *json-serialization*)
                :collect (cons name (let* ((slot (find-slot (class-of object) name))
                                           (val (slot-value object name)))
                                      (cond
                                        ((typep slot 'persistent-association-end-effective-slot-definition)
                                         (if (listp val)
                                             (mapcar #'oid-of val)
                                             (oid-of val)))
                                        (t
                                         val)))))))
        ;; note that because inherited slots are not covered by the
        ;; metaclass, edition must be added manually.  This sucks.
        (push (cons 'edition (edition-of object)) props)
        (push (cons 'id (oid-of object)) props)
        (encode-json props stream)))

    ;; you might also find the following useful: it encodes timestamp
    ;; objects as number of milliseconds since Jan 1 1970 00:00:00 UTC,
    ;; which I find preferable in JS as I can say new Date(milliseconds)

    (defmethod encode-json ((value timestamp) &optional stream)
      (encode-json (+ (* 1000 (timestamp-to-unix value))
                      (timestamp-millisecond value)) stream))


Example usage
=============

(my-defpclass db-user (db-versioned-object)
  ((create-time (transaction-timestamp) :type timestamp :index t)
   (last-seen nil :type (or null timestamp) :index t)
   (userid :type (text 32) :unique t)
   (name nil :type (or null (text 64)) :index t)
   (email :type (text 128) :unique t)
   (password nil :type (or nil (text 128)) :json nil))) ;; password not serialized

(my-defpclass db-group (db-versioned-object)
  ((name :type (text 32) :unique t)
   (description :type (text 255))))

(my-def-association
  ((:class db-user :slot groups :type (prc:set db-group) :json 5) ;; 5 is "heavy"
   (:class db-group :slot users :type (prc:set db-user) :json nil)) ;; don't serialize users
  (:cache t))

(db-deploy-schema)

(defvar groups
  (with-transaction
    (list (make-instance 'db-group
                         :name "admin"
                         :description "Power is not for everyone, so take care!")
          (make-instance 'db-group
                         :name "editor"
                         :description "Users allowed to edit pages")
          (make-instance 'db-group
                         :name "programmer"
                         :description "Users allowed to mess with internals"))))

(defvar u
  (with-transaction
    (make-instance 'db-user
                   :name "Mihai Bazon"
                   :userid "mishoo"
                   :email "mihai at bazon.net"
                   :password "foo"
                   :groups groups)))

(with-transaction
  (revive-instance u)
  (encode-json u))

;; {"id":325330,"edition":0,"email":"mihai at bazon.net","name":"Mihai
;; Bazon","userid":"mishoo","lastSeen":null,"createTime":1253439288138}

(with-transaction
  (revive-instance u)
  (encode-json (groups-of u)))

;; [{"id":69012,"edition":0,"description":"Power is not for everyone,
;; so take
;; care!","name":"admin"},{"id":134548,"edition":0,"description":"Users
;; allowed to edit
;; pages","name":"editor"},{"id":200084,"edition":0,"description":"Users
;; allowed to mess with internals","name":"programmer"}]

;; the following includes the "groups" array because we increase the
;; maximum weight:

(let ((*json-serialization* 5))
  (with-transaction
    (revive-instance u)
    (encode-json u)))

;; {"id":325330,"edition":0,"comments":null,"pages":null,
;; "groups":[69012,134548,200084],"email":"mihai at bazon.net","name":"Mihai Bazon",
;; "userid":"mishoo","lastSeen":null,"createTime":1253439288138}


That's it
=========

Hope someone will find it useful.  I'm still learning, if I made any blatant
mistake or if anything I wrote can be written nicer/cleaner, I'd appreciate
any hints. ;-)

Cheers,
-Mihai