Skip to content
Permalink
Browse files

Move away from using the provided CLOS slot type and instead provide …

…our own that isn't coerced in any way. Fixes type downgrading.
  • Loading branch information...
Shinmera committed Jan 7, 2017
1 parent eb387c0 commit d6a2031b05b1188958ee66bb62179846e30cdca6
Showing with 53 additions and 43 deletions.
  1. +33 −35 protocol.lisp
  2. +20 −8 typed-slot-class.lisp
@@ -99,29 +99,29 @@
(format stream "~a" (maybe-sval object 'name))))

(define-protocol-class profile (named-object server-object)
((name :type username)
(password :initarg :password :accessor password :type password)
(lifetime :initarg :lifetime :accessor lifetime :type (integer 0)))
((name :slot-type username)
(password :initarg :password :accessor password :slot-type password)
(lifetime :initarg :lifetime :accessor lifetime :slot-type (integer 0)))
(:default-initargs
:lifetime *default-profile-lifetime*))

(define-protocol-class user (named-object server-object)
((connections :initarg :connections :accessor connections :type list)
(channels :initarg :channels :accessor channels :type list))
((connections :initarg :connections :accessor connections :slot-type list)
(channels :initarg :channels :accessor channels :slot-type list))
(:default-initargs
:connections ()
:channels ()))

(define-protocol-class connection (server-object)
((user :initarg :user :accessor user :type (or null user))
(hostname :initarg :hostname :accessor hostname :type string)
(port :initarg :port :accessor port :type (integer 0))))
((user :initarg :user :accessor user :slot-type (or null user))
(hostname :initarg :hostname :accessor hostname :slot-type string)
(port :initarg :port :accessor port :slot-type (integer 0))))

(define-protocol-class channel (named-object server-object)
((name :type channelname)
(permissions :initarg :permissions :accessor permissions :type list)
(lifetime :initarg :lifetime :accessor lifetime :type (integer 0))
(users :initarg :users :accessor users :type list))
((name :slot-type channelname)
(permissions :initarg :permissions :accessor permissions :slot-type list)
(lifetime :initarg :lifetime :accessor lifetime :slot-type (integer 0))
(users :initarg :users :accessor users :slot-type list))
(:default-initargs
:permissions ()
:lifetime *default-channel-lifetime*
@@ -132,9 +132,9 @@
())

(define-protocol-class update (wire-object)
((id :initarg :id :accessor id :type id)
(clock :initarg :clock :accessor clock :type integer)
(from :initarg :from :accessor from :type username))
((id :initarg :id :accessor id :slot-type id)
(clock :initarg :clock :accessor clock :slot-type integer)
(from :initarg :from :accessor from :slot-type username))
(:default-initargs
:id (next-id)
:clock (get-universal-time)))
@@ -145,18 +145,14 @@
:id (maybe-sval update 'id))))

(define-protocol-class ping (update)
((clock :initarg :clock :accessor clock :type integer))
(:default-initargs
:clock (get-universal-time)))
())

(define-protocol-class pong (update)
((clock :initarg :clock :accessor clock :type integer))
(:default-initargs
:clock (get-universal-time)))
())

(define-protocol-class connect (update)
((password :initarg :password :accessor password :type (or null password))
(version :initarg :version :accessor version :type string))
((password :initarg :password :accessor password :slot-type (or null password))
(version :initarg :version :accessor version :slot-type string))
(:default-initargs
:password NIL
:version (protocol-version)))
@@ -165,16 +161,16 @@
())

(define-protocol-class register (update)
((password :initarg :password :accessor password :type password)))
((password :initarg :password :accessor password :slot-type password)))

(define-protocol-class channel-update (update)
((channel :initarg :channel :accessor channel :type channelname)))
((channel :initarg :channel :accessor channel :slot-type channelname)))

(define-protocol-class target-update (update)
((target :initarg :target :accessor target :type username)))
((target :initarg :target :accessor target :slot-type username)))

(define-protocol-class text-update (update)
((text :initarg :text :accessor text :type string)))
((text :initarg :text :accessor text :slot-type string)))

(defmethod print-object ((update text-update) stream)
(print-unreadable-object (update stream :type T)
@@ -189,7 +185,8 @@
())

(define-protocol-class create (channel-update)
())
((channel :initarg :channel :accessor channel :slot-type (or null channelname)))
(:default-initargs :channel NIL))

(define-protocol-class kick (channel-update target-update)
())
@@ -198,21 +195,22 @@
())

(define-protocol-class permissions (channel-update)
((permissions :initarg :permissions :accessor permissions :type list)))
((permissions :initarg :permissions :accessor permissions :slot-type list)))

(define-protocol-class message (channel-update text-update)
())

(define-protocol-class users (channel-update)
((users :initarg :users :accessor users :type list)))
((users :initarg :users :accessor users :slot-type list))
(:default-initargs :users ()))

(define-protocol-class channels (update)
((channels :initarg :channels :accessor channels :type list))
((channels :initarg :channels :accessor channels :slot-type list))
(:default-initargs :channels ()))

(define-protocol-class user-info (target-update)
((registered :initarg :registered :accessor registered :type boolean)
(connections :initarg :connections :accessor connections :type (integer 1))))
((registered :initarg :registered :accessor registered :slot-type boolean)
(connections :initarg :connections :accessor connections :slot-type (integer 1))))

;; Errors
(define-protocol-class failure (text-update)
@@ -227,7 +225,7 @@
(:default-initargs :text "The connection is unstable. You may be disconnected soon."))

(define-protocol-class update-failure (failure)
((update-id :initarg :update-id :accessor update-id :type id)))
((update-id :initarg :update-id :accessor update-id :slot-type id)))

(defmethod print-object ((update update-failure) stream)
(print-unreadable-object (update stream :type T)
@@ -244,7 +242,7 @@
(:default-initargs :text "The FROM field did not match the known username of the connection."))

(define-protocol-class incompatible-version (update-failure)
((compatible-versions :initarg :compatible-versions :accessor compatible-versions :type cons))
((compatible-versions :initarg :compatible-versions :accessor compatible-versions :slot-type cons))
(:default-initargs :text "The server and client versions are not compatible."))

(define-protocol-class invalid-password (update-failure)
@@ -10,19 +10,19 @@

(defun check-compatible-slot-value (value object slot)
(cond ((eq value *unbound-value*)
(unless (eql T (c2mop:slot-definition-type slot))
(unless (eql T (slot-type slot))
(cerror "Unbind the slot anyway." 'incompatible-value-type-for-slot
:object object :slot (c2mop:slot-definition-name slot) :value *unbound-value* :type (c2mop:slot-definition-type slot))))
((not (typep value (c2mop:slot-definition-type slot)))
:object object :slot (c2mop:slot-definition-name slot) :value *unbound-value* :type (slot-type slot))))
((not (typep value (slot-type slot)))
(cerror "Write to the slot anyway." 'incompatible-value-type-for-slot
:object object :slot (c2mop:slot-definition-name slot) :value value :type (c2mop:slot-definition-type slot)))))
:object object :slot (c2mop:slot-definition-name slot) :value value :type (slot-type slot)))))

(defclass typed-slot (c2mop:standard-slot-definition)
())
((slot-type :initarg :slot-type :initform NIL :accessor slot-type)))

(defmethod print-object ((slot typed-slot) stream)
(print-unreadable-object (slot stream :type T :identity T)
(format stream "~s ~s ~s" (c2mop:slot-definition-name slot) :type (c2mop:slot-definition-type slot))))
(format stream "~s ~s ~s" (c2mop:slot-definition-name slot) :type (slot-type slot))))

(defclass typed-direct-slot-definition (typed-slot c2mop:standard-direct-slot-definition)
())
@@ -45,6 +45,17 @@
(defmethod c2mop:effective-slot-definition-class ((class typed-slot-class) &key)
(find-class 'typed-effective-slot-definition))

(defmethod c2mop:compute-effective-slot-definition ((class typed-slot-class) name direct-slots)
(declare (ignore name))
(let ((effective-slot (call-next-method)))
(loop for direct-slot in direct-slots
do (when (and (typep direct-slot 'typed-direct-slot-definition)
(eql (c2mop:slot-definition-name direct-slot)
(c2mop:slot-definition-name effective-slot)))
(setf (slot-type effective-slot) (slot-type direct-slot))
(return)))
effective-slot))

(defmethod (setf c2mop:slot-value-using-class) :before (value (class typed-slot-class) object (slot typed-slot))
(check-compatible-slot-value value object slot))

@@ -59,8 +70,9 @@
(defmethod shared-initialize :after ((object typed-object) slot-names &key)
(let ((slots (c2mop:class-slots (class-of object))))
(flet ((process-slot (slot)
(unless (slot-boundp object (c2mop:slot-definition-name slot))
(check-compatible-slot-value *unbound-value* object slot))))
(when (typep slot 'typed-slot)
(unless (slot-boundp object (c2mop:slot-definition-name slot))
(check-compatible-slot-value *unbound-value* object slot)))))
(etypecase slot-names
(list (loop for name in slot-names
for slot = (find name slots :key #'c2mop:slot-definition-name)

0 comments on commit d6a2031

Please sign in to comment.
You can’t perform that action at this time.