src/validation/validation.lisp

   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 ;;;; ** Attributes
  10 (define-condition attribute-validation-condition (validation-condition)
  11   ((attribute :accessor attribute :initarg :attribute :initform nil)))
  12
  13 (defgeneric validate-attribute (instance attribute &optional value)
  14   (:documentation "
  15 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.")
  16   (:method (instance attribute &optional (value nil value-provided-p))
  17     (let ((val (if value-provided-p
  18                      value
  19                      (attribute-value instance attribute)))
  20           (conditions))
  21       (handler-bind ((attribute-validation-condition
  22                       #'(lambda (c)
  23                           (setf conditions (cons c conditions))
  24                           (signal c))))
  25
  26           (dolist (f (find-validation-functions instance attribute))
  27             (funcall f instance attribute val)))
  28       (if conditions
  29           (values nil conditions)
  30           t))))
  31
  32
  33 (defmethod find-validation-functions (instance (attribute standard-attribute))
  34   (let ((foo  (validate-using attribute)))
  35     (warn "validation?~A " foo)
  36     foo))
  37
  38
  39 ;;;; ** Instances
  40 (define-condition instance-validation-condition (validation-condition)
  41   ((instance :accessor instance :initarg instance :initform nil)
  42    (conditions :accessor conditions :initarg :conditions :initform nil)))
  43
  44 (defmethod invalid-instance-p (instance attributes)
  45   (let (condition)
  46     (handler-bind ((instance-validation-condition
  47                   #'(lambda (c)
  48                       (setf condition c))))
  49       (validate-instance instance attributes))
  50     condition))
  51
  52 (defmethod validate-instance (instance attributes)
  53   (let (all-conditions)
  54     (dolist (att attributes)
  55       (multiple-value-bind (is-valid-p conditions)
  56           (validate-attribute instance att)
  57         (unless is-valid-p
  58           (setf all-conditions (nconc conditions all-conditions)))))
  59     (if all-conditions
  60         (progn (signal 'instance-validation-condition
  61                        :message "Invalid Instance"
  62                        :instance instance
  63                        :conditions all-conditions)
  64                (values nil all-conditions))
  65
  66         t)))
  67
  68
  69 ;;;; Attribute Validation Functions
  70 ;;;; I have not quite figured all this out yet.
  71 ;;;; A generic validation system needs more thought than i've given it, but this is a start.
  72
  73 (defun validate-string-exists (instance attribute value)
  74     (if (or
  75          (not (stringp value))
  76          (not (< 0 (length value))))
  77         (signal 'attribute-validation-condition
  78                 :message (format nil "You must enter a value for ~A."
  79                                  (label attribute))
  80                 :attribute attribute)))
  81
  82
  83 (defun validate-true (instance attribute value)
  84     (unless value
  85       (signal 'attribute-validation-condition
  86               :message (format nil "~A is required."
  87                                (label attribute))
  88               :attribute attribute)))