| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | ;;;; Validation Conditions |
| 4 | |
| 5 | (define-condition validation-condition () |
| 6 | ((message :accessor message :initarg :message :initform "Invalid value") |
| 7 | (value :accessor value :initarg :value :initform (warn "condition was not given a value")))) |
| 8 | |
| 9 | |
| 10 | ;;;; ** Attributes |
| 11 | (define-condition attribute-validation-condition (validation-condition) |
| 12 | ((attribute :accessor attribute :initarg :attribute :initform nil))) |
| 13 | |
| 14 | (defgeneric validate-attribute (instance attribute) |
| 15 | (:documentation " |
| 16 | Returns T if the ATTRIBUTE-VALUE in INSTANCE passes all the validation functions. Otherwise, returns (values nil conditions) where CONDITIONS is a list of conditions representing the validation errors the slot.") |
| 17 | (:method (instance attribute) |
| 18 | (let (conditions) |
| 19 | (handler-bind ((attribute-validation-condition |
| 20 | #'(lambda (c) |
| 21 | (setf conditions (cons c conditions)) |
| 22 | (signal c)))) |
| 23 | (dolist (f (find-validation-functions instance attribute)) |
| 24 | (funcall f instance attribute))) |
| 25 | (if conditions |
| 26 | (values nil conditions) |
| 27 | t))) |
| 28 | (:method (instance (attribute symbol)) |
| 29 | (validate-attribute instance (find-attribute instance attribute)))) |
| 30 | |
| 31 | |
| 32 | (defmethod find-validation-functions (instance (attribute standard-attribute)) |
| 33 | (getf (attribute.plist attribute) :validate-using)) |
| 34 | |
| 35 | |
| 36 | ;;;; ** Instances |
| 37 | (define-condition instance-validation-condition (validation-condition) |
| 38 | ((instance :accessor instance :initarg instance :initform nil) |
| 39 | (conditions :accessor conditions :initarg :conditions :initform nil))) |
| 40 | |
| 41 | (defmethod invalid-instance-p (instance attributes) |
| 42 | (let (condition) |
| 43 | (handler-bind ((instance-validation-condition |
| 44 | #'(lambda (c) |
| 45 | (setf condition c)))) |
| 46 | (validate-instance instance attributes)) |
| 47 | condition)) |
| 48 | |
| 49 | (defmethod validate-instance (instance attributes) |
| 50 | (let (all-conditions) |
| 51 | (dolist (att attributes) |
| 52 | (multiple-value-bind (is-valid-p conditions) |
| 53 | (validate-attribute instance att) |
| 54 | (unless is-valid-p |
| 55 | (setf all-conditions (nconc conditions all-conditions))))) |
| 56 | (if all-conditions |
| 57 | (progn (signal 'instance-validation-condition |
| 58 | :message "Invalid Instance" |
| 59 | :instance instance |
| 60 | :conditions all-conditions) |
| 61 | (values nil all-conditions)) |
| 62 | |
| 63 | t))) |
| 64 | |
| 65 | ;;;; Attribute Validation Functions |
| 66 | ;;;; I have not quite figured all this out yet. |
| 67 | ;;;; A generic validation system needs more thought than i've given it, but this is a start. |
| 68 | |
| 69 | (defun validate-string-exists (instance attribute) |
| 70 | (let ((value (lol::attribute-value instance attribute))) |
| 71 | (if (or |
| 72 | (not (stringp value)) |
| 73 | (not (< 0 (length value)))) |
| 74 | (signal 'attribute-validation-condition |
| 75 | :message (format nil "You must enter a value for ~A." |
| 76 | (getf (attribute.plist attribute) :label)) |
| 77 | :attribute attribute)))) |
| 78 | |
| 79 | |
| 80 | (defun validate-true (instance attribute) |
| 81 | |
| 82 | (warn "validate ~A ~A" instance attribute) |
| 83 | (let ((value (lol::attribute-value instance attribute))) |
| 84 | (warn "value is ~A" value) |
| 85 | (unless value |
| 86 | |
| 87 | (signal 'attribute-validation-condition |
| 88 | :message (format nil "~A must be true." |
| 89 | (getf (attribute.plist attribute) :label)) |
| 90 | :attribute attribute)))) |
| 91 | |
| 92 | |
| 93 | |
| 94 | |
| 95 | |