├── .gitignore ├── LICENSE ├── README.md ├── clavier.asd ├── clavier.lisp ├── clavier.test.asd ├── package.lisp └── test.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Mariano Montone 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Clavier 2 | ---------- 3 | 4 | [![Quicklisp](http://quickdocs.org/badge/clavier.svg)](http://quickdocs.org/clavier/) 5 | [![MIT License](https://img.shields.io/badge/license-MIT-blue.svg)](./LICENSE) 6 | 7 | *Clavier* is a general purpose validation library for Common Lisp. 8 | 9 | Install 10 | ------- 11 | 12 | Through Quicklisp: 13 | 14 | ```lisp 15 | (ql:quickload :clavier) 16 | ``` 17 | Getting started 18 | --------------- 19 | 20 | Validators are class instances that validate the arguments passed to the `validate` function: 21 | 22 | ```lisp 23 | (let ((validator (make-instance 'equal-to-validator :object 22))) 24 | (validate validator 22 :error-p t)) 25 | 26 | ;=> T 27 | ``` 28 | 29 | If the validator succeeds, the validate function returns `T`. If it fails, the validate function either signals a validation error, or returns `NIL` and a validation message depending on the value of the `:error-p` argument. 30 | 31 | ```lisp 32 | (let ((validator (make-instance 'equal-to-validator :object 22))) 33 | (validate validator 33 :error-p nil)) 34 | 35 | ;=> 36 | ;NIL 37 | ;"33 is not equal to 22" 38 | ``` 39 | 40 | Validators are implemented as funcallable classes. So, alternatively to using the `validate` function, it is possible to just funcall the validator, like this: 41 | 42 | ```lisp 43 | (let ((validator (make-instance 'equal-to-validator :object 22))) 44 | (funcall validator 22 :error-p t)) 45 | 46 | ;=> T 47 | ``` 48 | 49 | ## Validation expressions 50 | 51 | It is possible to create validators with a more convenient syntax. Each validator provides a builder function. For instance, and equal-to-validator can be built like this: 52 | 53 | ```lisp 54 | (funcall (== 100) 100) ;=> T 55 | (funcall (== 100) 99) ;=> NIL 56 | ``` 57 | 58 | ## Validators composition 59 | 60 | This allows to compose validators, using `==`, `~=`, `&&`, `||` as the composition operands: 61 | 62 | ```lisp 63 | (let ((validator (|| (&& (greater-than 20) 64 | (less-than 30)) 65 | (|| (&& (greater-than 1) 66 | (less-than 10)) 67 | (== 100))))) 68 | (funcall validator 5)) 69 | ``` 70 | 71 | For example, this is how to accept a blank object, but validate it if it isn't blank: 72 | 73 | 74 | ~~~lisp 75 | (defparameter *validator* (clavier:|| 76 | (clavier:blank) 77 | (clavier:&& (clavier:is-a-string) 78 | (clavier:len :min 10))) 79 | "Allow a blank value. When non blank, validate.") 80 | 81 | (funcall *validator* "") 82 | ;; => 83 | T 84 | NIL 85 | 86 | (funcall *validator* "asdfasdfasdf") 87 | ;; => 88 | T 89 | NIL 90 | 91 | (funcall *validator* "asdf") 92 | ;; => 93 | NIL 94 | "Length of \"asdf\" is less than 10" 95 | 96 | (funcall *validator* 2) 97 | ;; => 98 | NIL 99 | "2 is not a string" 100 | ~~~ 101 | 102 | 103 | ## Validators messages 104 | 105 | Validators messages to be used when validation fails can be customized passing an `:message` argument when building the validator 106 | 107 | ## Catching and collecting validation errors 108 | 109 | Validation errors can be controlled globally by setting the dynamic variable `*signal-validation-errors*`, which is `NIL` by default (no validation errors are signaled by default). 110 | 111 | There's also the `with-signal-validation-errors` macro to specify whether validation errors should be signaled or not in a dynamic extent. For instance, this code signals a validation error: 112 | 113 | ```lisp 114 | (let ((validator (make-instance 'equal-to-validator :object 22))) 115 | (with-signal-validation-errors (t) 116 | (validate validator 33))) 117 | ``` 118 | 119 | Use the `collecting-validation-errors` macro to collect validation errors happening in a dynamic extent: 120 | 121 | ```lisp 122 | (let ((validator (make-instance 'equal-to-validator :object 22))) 123 | (collecting-validation-errors (errors found-p) 124 | (progn 125 | (funcall validator 33 :error-p t) 126 | (funcall validator 44 :error-p t)) 127 | (print errors) 128 | (print found-p))) 129 | ;=> 130 | ;(# 131 | ; #) 132 | ;T 133 | ``` 134 | 135 | ## Validators list: 136 | 137 | This is the list of available validator classes and their shortcut function: 138 | 139 | * equal-to-validator `(==)` 140 | * not-equal-to-validator `(~=)` 141 | * blank-validator `(blank)` 142 | * not-blank-validator `(not-blank)` 143 | * true-validator `(is-true)` 144 | * false-validator `(is-false)` 145 | * type-validator `(is-a type)` 146 | * string-validator `(is-a-string)` 147 | * boolean-validator `(is-a-boolean)` 148 | * integer-validator `(is-an-integer)` 149 | * symbol-validator `(is-a-symbol)` 150 | * keyword-validator `(is-a-keyword)` 151 | * list-validator `(is-a-list)` 152 | * function-validator `(fn function message)` 153 | * email-validator `(valid-email)` 154 | * regex-validator `(matches-regex regex-pattern)` 155 | * url-validator `(valid-url)` 156 | * datetime-validator `(valid-datetime)` 157 | * pathname-validator `(valid-pathname)` 158 | * not-validator `(~ validator)` 159 | * and-validator `(&& validator1 validator2)` 160 | * or-validator `(|| validator1 validator2)` 161 | * one-of-validator `(one-of options)` 162 | * less-than-validator `(less-than number)` 163 | * greater-than-validator `(greater-than number)` 164 | * length-validator `(len)` 165 | -------------------------------------------------------------------------------- /clavier.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:clavier 2 | :serial t 3 | :description "Clavier: A Common Lisp validation library" 4 | :author "Mariano Montone" 5 | :license "MIT" 6 | :homepage "https://github.com/mmontone/clavier" 7 | :long-description 8 | #.(uiop:read-file-string 9 | (uiop:subpathname *load-pathname* "README.md")) 10 | :depends-on (#:alexandria 11 | #:cl-ppcre 12 | #:closer-mop 13 | #:chronicity 14 | #:cl-fad) 15 | :components ((:file "package") 16 | (:file "clavier")) 17 | :in-order-to ((asdf:test-op 18 | (asdf:test-op :clavier.test)))) 19 | -------------------------------------------------------------------------------- /clavier.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:clavier) 2 | 3 | (defvar *signal-validation-errors* nil) 4 | 5 | (defun call-with-signal-validation-errors (func &optional (signal t)) 6 | (let ((*signal-validation-errors* signal)) 7 | (funcall func))) 8 | 9 | (defmacro with-signal-validation-errors ((&optional (signal t)) &body body) 10 | "Enables/disables validation errors in body 11 | 12 | Args: - signal(boolean) : If **T**, errors are signaled. If **NIL**, they are not." 13 | `(call-with-signal-validation-errors (lambda () ,@body) ,signal)) 14 | 15 | (defmacro collecting-validation-errors ((errors found-p) expr &body body) 16 | `(multiple-value-bind (,errors ,found-p) 17 | (%collecting-validation-errors 18 | (lambda () ,expr)) 19 | ,@body)) 20 | 21 | (define-condition validation-error (error) 22 | ((target :initarg :target 23 | :initform (error "Set up the target") 24 | :reader validation-error-target) 25 | (error-msg :initarg :error-msg 26 | :initform (error "Provide the error message") 27 | :reader validation-error-message)) 28 | (:report (lambda (c s) 29 | (format s "~A" (validation-error-message c))))) 30 | 31 | (defmethod print-object ((validation-error validation-error) stream) 32 | (print-unreadable-object (validation-error stream :type t :identity t) 33 | (format stream "~A: ~A" 34 | (validation-error-target validation-error) 35 | (validation-error-message validation-error)))) 36 | 37 | (defun validation-error (target error-msg &rest args) 38 | (cerror "Skip validation" 39 | 'validation-error 40 | :target target 41 | :error-msg (apply #'format nil (cons error-msg args)))) 42 | 43 | (defun %collecting-validation-errors (func) 44 | (let ((errors nil)) 45 | (handler-bind 46 | ((validation-error 47 | (lambda (c) 48 | (push c errors) 49 | (continue c)))) 50 | (funcall func)) 51 | (values errors (plusp (length errors))))) 52 | 53 | (defclass validator (closer-mop:funcallable-standard-object) 54 | ((message :initarg :message 55 | :accessor message 56 | :type (or null string function) 57 | :initform (error "Provide the validation error message"))) 58 | (:metaclass closer-mop:funcallable-standard-class)) 59 | 60 | (defmethod initialize-instance :after ((validator validator) &rest initargs) 61 | (declare (ignorable initargs)) 62 | (closer-mop:set-funcallable-instance-function 63 | validator 64 | (lambda (&rest args) 65 | (apply #'validate validator args)))) 66 | 67 | (defclass validator-collection (validator) 68 | ((validators :initarg :validators 69 | :accessor validators 70 | :initform nil)) 71 | (:metaclass closer-mop:funcallable-standard-class) 72 | (:default-initargs :message (lambda (&rest args) 73 | (declare (ignorable args)) 74 | ""))) 75 | 76 | (defclass equal-to-validator (validator) 77 | ((object :initarg :object 78 | :accessor object 79 | :initform (error "Provide the object"))) 80 | (:default-initargs 81 | :message 82 | (lambda (validator object) 83 | (format nil "~A is not equal to ~A" object (object validator)))) 84 | (:metaclass closer-mop:funcallable-standard-class)) 85 | 86 | (defclass not-equal-to-validator (validator) 87 | ((object :initarg :object 88 | :accessor object 89 | :initform (error "Provide the object"))) 90 | (:default-initargs 91 | :message 92 | (lambda (validator object) 93 | (format nil "~A is equal to ~A" object (object validator)))) 94 | (:metaclass closer-mop:funcallable-standard-class)) 95 | 96 | (defclass blank-validator (validator) 97 | () 98 | (:default-initargs 99 | :message (lambda (validator object) 100 | (declare (ignorable validator object)) 101 | (format nil "Should be blank"))) 102 | (:metaclass closer-mop:funcallable-standard-class)) 103 | 104 | (defclass not-blank-validator (validator) 105 | () 106 | (:default-initargs 107 | :message (lambda (validator object) 108 | (declare (ignorable validator object)) 109 | (format nil "Should not be blank"))) 110 | (:metaclass closer-mop:funcallable-standard-class)) 111 | 112 | (defclass true-validator (validator) 113 | () 114 | (:default-initargs 115 | :message (lambda (validator object) 116 | (declare (ignorable validator object)) 117 | (format nil "Is not true"))) 118 | (:metaclass closer-mop:funcallable-standard-class)) 119 | 120 | (defclass false-validator (validator) 121 | () 122 | (:default-initargs 123 | :message (lambda (validator object) 124 | (declare (ignorable validator object)) 125 | (format nil "Is not false"))) 126 | (:metaclass closer-mop:funcallable-standard-class)) 127 | 128 | (defclass type-validator (validator) 129 | ((type :initarg :type 130 | :accessor validator-type 131 | :initform (error "Provide the type"))) 132 | (:default-initargs 133 | :message (lambda (validator object) 134 | (format nil "~A is not of type ~A" object (validator-type validator)))) 135 | (:metaclass closer-mop:funcallable-standard-class)) 136 | 137 | (defclass string-validator (type-validator) 138 | () 139 | (:default-initargs 140 | :type 'string 141 | :message (lambda (validator object) 142 | (declare (ignore validator)) 143 | (format nil "~S is not a string" object))) 144 | (:metaclass closer-mop:funcallable-standard-class)) 145 | 146 | (defclass boolean-validator (type-validator) 147 | () 148 | (:default-initargs 149 | :type 'boolean 150 | :message (lambda (validator object) 151 | (declare (ignorable validator)) 152 | (format nil "~A is not a boolean" object))) 153 | (:metaclass closer-mop:funcallable-standard-class)) 154 | 155 | (defclass integer-validator (type-validator) 156 | () 157 | (:default-initargs 158 | :type 'integer 159 | :message (lambda (validator object) 160 | (declare (ignorable validator)) 161 | (format nil "~A is not an integer" object))) 162 | (:metaclass closer-mop:funcallable-standard-class)) 163 | 164 | (defclass symbol-validator (type-validator) 165 | () 166 | (:default-initargs 167 | :type 'symbol 168 | :message (lambda (validator object) 169 | (declare (ignorable validator)) 170 | (format nil "~A is not a symbol" object))) 171 | (:metaclass closer-mop:funcallable-standard-class)) 172 | 173 | (defclass keyword-validator (type-validator) 174 | () 175 | (:default-initargs 176 | :type 'keyword 177 | :message (lambda (validator object) 178 | (declare (ignorable validator)) 179 | (format nil "~A is not a keyword" object))) 180 | (:metaclass closer-mop:funcallable-standard-class)) 181 | 182 | (defclass list-validator (type-validator) 183 | () 184 | (:default-initargs 185 | :type 'list 186 | :message (lambda (validator object) 187 | (declare (ignorable validator)) 188 | (format nil "~A is not a list" object))) 189 | (:metaclass closer-mop:funcallable-standard-class)) 190 | 191 | 192 | (defclass function-validator (validator) 193 | ((function :initarg :function 194 | :accessor validator-function 195 | :initform (error "Provide the function"))) 196 | (:metaclass closer-mop:funcallable-standard-class)) 197 | 198 | (defclass email-validator (validator) 199 | () 200 | (:default-initargs 201 | :message (lambda (validator object) 202 | (declare (ignorable validator)) 203 | (format nil "The email is invalid: ~A" object))) 204 | (:metaclass closer-mop:funcallable-standard-class)) 205 | 206 | (defclass regex-validator (validator) 207 | ((regex :initarg :regex 208 | :initform (error "Provide the regex") 209 | :accessor validator-regex)) 210 | (:default-initargs 211 | :message (lambda (validator object) 212 | (declare (ignorable validator object)) 213 | (format nil "~A does not match the regex ~S" object (validator-regex validator)))) 214 | (:metaclass closer-mop:funcallable-standard-class)) 215 | 216 | (defclass url-validator (validator) 217 | () 218 | (:default-initargs 219 | :message (lambda (validator object) 220 | (declare (ignorable validator object)) 221 | (format nil "~A is not a valid URL" object))) 222 | (:metaclass closer-mop:funcallable-standard-class)) 223 | 224 | (defclass datetime-validator (validator) 225 | () 226 | (:default-initargs 227 | :message (lambda (validator object) 228 | (declare (ignorable validator object)) 229 | (format nil "~A is not a valid timestamp" object))) 230 | (:metaclass closer-mop:funcallable-standard-class)) 231 | 232 | (defclass pathname-validator (validator) 233 | ((absolute-p :initarg :absolute-p 234 | :accessor absolute-p 235 | :initform nil 236 | :documentation "If the pathname should be absolute") 237 | (probe-p :initarg :probe-p 238 | :accessor probe-p 239 | :initform nil 240 | :documentation "Probe existance of pathname") 241 | (pathname-type :initarg :pathname-type 242 | :accessor pathname-type* 243 | :initform nil 244 | :documentation "The pathname type")) 245 | (:default-initargs 246 | :message (lambda (validator object) 247 | (declare (ignorable validator object)) 248 | (format nil "~A is not a valid pathname" object))) 249 | (:metaclass closer-mop:funcallable-standard-class)) 250 | 251 | (defclass not-validator (validator) 252 | ((validator :initarg :validator 253 | :accessor validator 254 | :initform (error "Provide the validator"))) 255 | (:default-initargs 256 | :message (lambda (validator object) 257 | (format nil "Not ~A" (validator-message (validator validator) object)))) 258 | (:metaclass closer-mop:funcallable-standard-class)) 259 | 260 | (defclass and-validator (validator) 261 | ((x :initarg :x 262 | :accessor x 263 | :initform (error "Provide the first validator")) 264 | (y :initarg :y 265 | :accessor y 266 | :initform (error "Provide the second validator"))) 267 | (:default-initargs 268 | :message (lambda (validator object) 269 | (if (not (validate (x validator) object :error-p nil)) 270 | (validator-message (x validator) object) 271 | (validator-message (y validator) object)))) 272 | (:metaclass closer-mop:funcallable-standard-class)) 273 | 274 | (defclass or-validator (validator) 275 | ((x :initarg :x 276 | :accessor x 277 | :initform (error "Provide the first validator")) 278 | (y :initarg :y 279 | :accessor y 280 | :initform (error "Provide the second validator"))) 281 | (:default-initargs 282 | :message (lambda (validator object) 283 | (if (validate (x validator) object :error-p nil) 284 | (validator-message (x validator) object) 285 | (validator-message (y validator) object)))) 286 | (:metaclass closer-mop:funcallable-standard-class)) 287 | 288 | (defclass one-of-validator (validator) 289 | ((options :initarg :options 290 | :accessor options 291 | :initform (error "Provide the options"))) 292 | (:default-initargs 293 | :message (lambda (validator object) 294 | (declare (ignorable validator object)) 295 | (format nil "Should be one of ~{~A~}" (options validator)))) 296 | (:metaclass closer-mop:funcallable-standard-class)) 297 | 298 | (defclass less-than-validator (validator) 299 | ((number :initarg :number 300 | :accessor validator-number 301 | :initform (error "Provide the number"))) 302 | (:default-initargs 303 | :message (lambda (validator object) 304 | (declare (ignorable validator object)) 305 | (format nil "~A is not lower than ~A" object (validator-number validator)))) 306 | (:metaclass closer-mop:funcallable-standard-class)) 307 | 308 | (defclass greater-than-validator (validator) 309 | ((number :initarg :number 310 | :accessor validator-number 311 | :initform (error "Provide the number"))) 312 | (:default-initargs 313 | :message (lambda (validator object) 314 | (declare (ignorable validator object)) 315 | (format nil "~A is not greater than ~A" object (validator-number validator)))) 316 | (:metaclass closer-mop:funcallable-standard-class)) 317 | 318 | (defclass length-validator (validator) 319 | ((min :initarg :min 320 | :accessor validator-min 321 | :initform nil 322 | :documentation "Minimum length") 323 | (max :initarg :max 324 | :accessor validator-max 325 | :initform nil 326 | :documentation "Maximum length") 327 | (length :initarg :length 328 | :accessor validator-length 329 | :initform nil 330 | :documentation "The expected length") 331 | (min-message :initarg :min-message 332 | :accessor validator-min-message 333 | :initform nil 334 | :documentation "Message for when length is below minimum") 335 | (max-message :initarg :max-message 336 | :accessor validator-max-message 337 | :initform nil 338 | :documentation "Message for when length is above maximum")) 339 | (:default-initargs :message nil) 340 | (:metaclass closer-mop:funcallable-standard-class)) 341 | 342 | (defmethod message ((validator length-validator)) 343 | (lambda (validator object) 344 | (cond 345 | ((and (validator-length validator) 346 | (not (= (validator-length validator) (length object)))) 347 | (or (slot-value validator 'message) 348 | (format nil "~s has not length: ~a" object (validator-length validator)))) 349 | ((and (validator-min validator) 350 | (< (length object) (validator-min validator))) 351 | (or (validator-min-message validator) 352 | (format nil "Length of ~s is less than ~a" object (validator-min validator)))) 353 | ((and (validator-max validator) 354 | (> (length object) (validator-max validator))) 355 | (or (validator-max-message validator) 356 | (format nil "Length of ~s is more than ~a" object (validator-max validator))))))) 357 | 358 | (defun validate (validator object &rest args &key (error-p *signal-validation-errors*) message &allow-other-keys) 359 | (if (not (apply #'%validate validator object args)) 360 | (let ((message (or message (validator-message validator object)))) 361 | (if error-p 362 | (validation-error object message) 363 | (values nil message))) 364 | (values t nil))) 365 | 366 | (defgeneric %validate (validator object &rest args)) 367 | 368 | (defmethod %validate ((validator validator-collection) object &rest args) 369 | (declare (ignorable args)) 370 | (loop for validator in (validators validator) 371 | do (validate validator object :error-p t))) 372 | 373 | (defmethod %validate ((validator equal-to-validator) object &rest args) 374 | (declare (ignorable args)) 375 | (equalp object (object validator))) 376 | 377 | (defmethod %validate ((validator not-equal-to-validator) object &rest args) 378 | (declare (ignorable args)) 379 | (not (equalp object (object validator)))) 380 | 381 | (defmethod %validate ((validator type-validator) object &rest args) 382 | (declare (ignorable args)) 383 | (typep object (validator-type validator))) 384 | 385 | (defmethod %validate ((validator function-validator) object &rest args) 386 | (declare (ignorable args)) 387 | (funcall (validator-function validator) object)) 388 | 389 | (defmethod %validate ((validator blank-validator) object &rest args) 390 | (declare (ignorable validator args)) 391 | (or (null object) 392 | (equalp object ""))) 393 | 394 | (defmethod %validate ((validator not-blank-validator) object &rest args) 395 | (declare (ignorable validator args)) 396 | (not (or (null object) 397 | (equalp object "")))) 398 | 399 | (defmethod %validate ((validator true-validator) object &rest args) 400 | (declare (ignorable validator args)) 401 | (eql t object)) 402 | 403 | (defmethod %validate ((validator false-validator) object &rest args) 404 | (declare (ignorable validator args)) 405 | (null object)) 406 | 407 | (defmethod %validate ((validator length-validator) object &rest args) 408 | (declare (ignorable args)) 409 | (and (or (null (validator-length validator)) 410 | (= (length object) (validator-length validator))) 411 | (or (null (validator-min validator)) 412 | (>= (length object) (validator-min validator))) 413 | (or (null (validator-max validator)) 414 | (<= (length object) (validator-max validator))))) 415 | 416 | (defun valid-email-address-p (string) 417 | (not (null 418 | (ppcre:scan "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\\.[a-zA-Z]{2,}$" string)))) 419 | 420 | (defmethod %validate ((validator email-validator) object &rest args) 421 | (declare (ignorable args)) 422 | (valid-email-address-p object)) 423 | 424 | (defun valid-url-p (string) 425 | (not (null (ppcre:scan "((([A-Za-z]{3,9}:(?:\\/\\/)?)(?:[\\-;:&=\\+\\$,\\w]+@)?[A-Za-z0-9\\.\\-]+|(?:www\\.|[\\-;:&=\\+\\$,\\w]+@)[A-Za-z0-9\\.\\-]+)((?:\\/[\\+~%\\/\\.\\w\\-_]*)?\\??(?:[\\-\\+=&;%@\\.\\w_]*)#?(?:[\\.\\!\\/\\\\\\w]*))?)" string)))) 426 | 427 | (defmethod %validate ((validator url-validator) object &rest args) 428 | (declare (ignorable args)) 429 | (valid-url-p object)) 430 | 431 | (defmethod %validate ((validator regex-validator) object &rest args) 432 | (declare (ignorable args)) 433 | (not (null (ppcre:scan (validator-regex validator) object)))) 434 | 435 | (defmethod %validate ((validator datetime-validator) object &rest args) 436 | (declare (ignorable args)) 437 | (not (null (chronicity:parse object)))) 438 | 439 | (defmethod %validate ((validator pathname-validator) object &rest args) 440 | (declare (ignorable args)) 441 | (and (pathname object) 442 | (or (not (absolute-p validator)) 443 | (fad:pathname-absolute-p (pathname object))) 444 | (or (not (pathname-type* validator)) 445 | (equalp (pathname-type (pathname object)) 446 | (pathname-type* validator))) 447 | (or (not (probe-p validator)) 448 | (probe-file (pathname object))))) 449 | 450 | (defmethod %validate ((validator not-validator) object &rest args) 451 | (declare (ignorable args)) 452 | (not (%validate (validator validator) object))) 453 | 454 | (defmethod %validate ((validator and-validator) object &rest args) 455 | (declare (ignorable args)) 456 | (and (validate (x validator) object) 457 | (validate (y validator) object))) 458 | 459 | (defmethod %validate ((validator or-validator) object &rest args) 460 | (if (getf args :signal-validation-errors) 461 | (handler-case 462 | (validate (x validator) object) 463 | (validation-error () 464 | (validate (y validator) object))) 465 | (or (validate (x validator) object) 466 | (validate (y validator) object)))) 467 | 468 | (defmethod %validate ((validator one-of-validator) object &rest args) 469 | (declare (ignorable args)) 470 | (member object (options validator) :test #'equalp)) 471 | 472 | (defmethod %validate ((validator less-than-validator) object &rest args) 473 | (declare (ignorable args)) 474 | (< object (validator-number validator))) 475 | 476 | (defmethod %validate ((validator greater-than-validator) object &rest args) 477 | (declare (ignorable args)) 478 | (> object (validator-number validator))) 479 | 480 | ;; Validator builder functions 481 | (defun == (object &optional message &rest args) 482 | (declare (ignorable args)) 483 | (apply #'make-instance 'equal-to-validator 484 | `(:object ,object 485 | ,@(when message 486 | (list :message (apply #'format nil message args)))))) 487 | 488 | (defun ~= (object &optional message &rest args) 489 | (apply #'make-instance 'not-equal-to-validator 490 | `(:object ,object 491 | ,@(when message 492 | (list :message (apply #'format nil message args)))))) 493 | 494 | (defun one-of (options &optional message &rest args) 495 | (apply #'make-instance 'one-of-validator 496 | `(:options ,options 497 | ,@(when message 498 | (list :message (apply #'format nil message args)))))) 499 | 500 | (defun blank (&optional message &rest args) 501 | (apply #'make-instance 'blank-validator 502 | (when message 503 | (list :message (apply #'format nil message args))))) 504 | 505 | (defun not-blank (&optional message &rest args) 506 | (apply #'make-instance 'not-blank-validator 507 | (when message 508 | (list :message (apply #'format nil message args))))) 509 | 510 | (defun is-true (&optional message &rest args) 511 | (apply #'make-instance 'is-true-validator 512 | (when message 513 | (list :message (apply #'format nil message args))))) 514 | 515 | (defun is-false (&optional message &rest args) 516 | (apply #'make-instance 'is-false-validator 517 | (when message 518 | (list :message (apply #'format nil message args))))) 519 | 520 | (defun greater-than (number &optional message &rest args) 521 | (apply #'make-instance 'greater-than-validator 522 | `(:number ,number 523 | ,@(when message 524 | (list :message (apply #'format nil message args)))))) 525 | 526 | (defun less-than (number &optional message &rest args) 527 | (apply #'make-instance 'less-than-validator 528 | `(:number ,number 529 | ,@(when message 530 | (list :message (apply #'format nil message args)))))) 531 | 532 | (defun ~ (validator &optional message &rest args) 533 | (apply #'make-instance 'not-validator 534 | `(:validator ,validator 535 | ,@(when message 536 | (list :message (apply #'format nil message args)))))) 537 | 538 | (defun && (x y &optional message &rest args) 539 | (apply #'make-instance 'and-validator 540 | `(:x ,x :y ,y 541 | ,@(when message 542 | (list :message (apply #'format nil message args)))))) 543 | 544 | ;; There's a problem when trying to compile || as function name on ECL 545 | ;; So, we don't define it. 546 | #-ecl 547 | (defun || (x y &optional message &rest args) 548 | (apply #'make-instance 'or-validator 549 | `(:x ,x :y ,y 550 | ,@(when message 551 | (list :message (apply #'format nil message args)))))) 552 | 553 | (defun fn (function message &rest args) 554 | (make-instance 'function-validator 555 | :function function 556 | :message (apply #'format nil message args))) 557 | 558 | (defun is-a (type &optional message &rest args) 559 | (apply #'make-instance 'type-validator 560 | `(:type ,type 561 | ,@(when message 562 | (list :message (apply #'format nil message args)))))) 563 | 564 | (defun is-a-string (&optional message &rest args) 565 | (apply #'make-instance 'string-validator 566 | (when message 567 | (list :message (apply #'format nil message args))))) 568 | 569 | (defun is-a-boolean (&optional message &rest args) 570 | (apply #'make-instance 'boolean-validator 571 | (when message 572 | (list :message (apply #'format nil message args))))) 573 | 574 | (defun is-an-integer (&optional message &rest args) 575 | (apply #'make-instance 'integer-validator 576 | (when message 577 | (list :message (apply #'format nil message args))))) 578 | 579 | (defun is-a-symbol (&optional message &rest args) 580 | (apply #'make-instance 'symbol-validator 581 | (when message 582 | (list :message (apply #'format nil message args))))) 583 | 584 | (defun is-a-keyword (&optional message &rest args) 585 | (apply #'make-instance 'keyword-validator 586 | (when message 587 | (list :message (apply #'format nil message args))))) 588 | 589 | (defun is-a-list (&optional message &rest args) 590 | (apply #'make-instance 'list-validator 591 | (when message 592 | (list :message (apply #'format nil message args))))) 593 | 594 | (defun valid-email (&optional message &rest args) 595 | (apply #'make-instance 'email-validator 596 | (when message 597 | (list :message (apply #'format nil message args))))) 598 | 599 | (defun valid-url (&optional message &rest args) 600 | (apply #'make-instance 'url-validator 601 | (when message 602 | (list :message (apply #'format nil message args))))) 603 | 604 | (defun valid-datetime (&optional message &rest args) 605 | (apply #'make-instance 'datetime-validator 606 | (when message 607 | (list :message (apply #'format nil message args))))) 608 | 609 | (defun valid-pathname (&optional message &rest args) 610 | (apply #'make-instance 'pathname-validator 611 | (when message 612 | (list :message (apply #'format nil message args))))) 613 | 614 | (defun matches-regex (regex &optional message &rest args) 615 | (apply #'make-instance 'regex-validator 616 | `(:regex ,regex 617 | ,@(when message 618 | (list :message (apply #'format nil message args)))))) 619 | 620 | (defun len (&key min max message min-message max-message) 621 | (apply #'make-instance 'length-validator 622 | :min min 623 | :max max 624 | (alexandria:flatten 625 | (remove-if #'null 626 | (list 627 | (when message 628 | (list :message message)) 629 | (when min-message 630 | (list :min-message min-message)) 631 | (when max-message 632 | (list :max-message max-message))))))) 633 | 634 | (defun validator-message (validator object) 635 | "Returns the validator message for the given object" 636 | (if (stringp (message validator)) 637 | (message validator) 638 | (funcall (message validator) 639 | validator 640 | object))) 641 | -------------------------------------------------------------------------------- /clavier.test.asd: -------------------------------------------------------------------------------- 1 | ;;;; validator.asd 2 | 3 | (asdf:defsystem #:clavier.test 4 | :serial t 5 | :description "Clavier tests" 6 | :author "Mariano Montone" 7 | :license "MIT" 8 | :depends-on (#:clavier #:stefil) 9 | :components ((:file "test")) 10 | :perform (asdf:test-op (o c) 11 | (uiop:symbol-call :clavier.test :clavier-tests))) 12 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:clavier 2 | (:use #:cl) 3 | (:export #:*signal-validation-errors* 4 | #:call-with-signal-validation-errors 5 | #:with-signal-validation-errors 6 | #:collecting-validation-errors 7 | #:validation-error 8 | #:validation-error-target 9 | #:validation-error-message 10 | #:validator 11 | #:validate 12 | #:message 13 | #:validator-message 14 | 15 | ;; Validators 16 | 17 | #:validator-collection 18 | #:equal-to-validator 19 | #:not-equal-to-validator 20 | #:blank-validator 21 | #:not-blank-validator 22 | #:type-validator 23 | #:string-validator 24 | #:boolean-validator 25 | #:integer-validator 26 | #:symbol-validator 27 | #:keyword-validator 28 | #:list-validator 29 | #:function-validator 30 | #:true-validator 31 | #:false-validator 32 | #:not-validator 33 | #:and-validator 34 | #:or-validator 35 | #:one-of-validator 36 | #:less-than-validator 37 | #:greater-than-validator 38 | #:email-validator 39 | #:regex-validator 40 | #:url-validator 41 | #:datetime-validator 42 | #:pathname-validator 43 | #:length-validator 44 | 45 | ;; Validator builders 46 | #:== 47 | #:~= 48 | #:one-of 49 | #:blank 50 | #:not-blank 51 | #:is-true 52 | #:is-false 53 | #:greater-than 54 | #:less-than 55 | #:~ 56 | #:&& 57 | #:|| 58 | #:fn 59 | #:is-a 60 | #:is-a-string 61 | #:is-a-boolean 62 | #:is-an-integer 63 | #:is-a-symbol 64 | #:is-a-keyword 65 | #:is-a-list 66 | #:valid-email 67 | #:matches-regex 68 | #:valid-url 69 | #:valid-datetime 70 | #:valid-pathname 71 | #:len)) 72 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :clavier.test 2 | (:use :cl :clavier :stefil) 3 | (:export :clavier-tests)) 4 | 5 | (in-package :clavier.test) 6 | 7 | (in-root-suite) 8 | 9 | (defsuite clavier-tests) 10 | 11 | (in-suite clavier-tests) 12 | 13 | ;; Validator errors 14 | (deftest validator-errors-test () 15 | (let ((validator (make-instance 'equal-to-validator :object 22))) 16 | (is (validate validator 22 :error-p t)) 17 | (signals validation-error 18 | (validate validator 33 :error-p t)) 19 | (collecting-validation-errors (errors found-p) 20 | (progn 21 | (funcall validator 33 :error-p t) 22 | (funcall validator 44 :error-p t)) 23 | (is (equalp (length errors) 2)) 24 | (is found-p)) 25 | (collecting-validation-errors (errors found-p) 26 | (progn 27 | (funcall validator 33) 28 | (funcall validator 44)) 29 | (is (not found-p)) 30 | (is (not errors))))) 31 | 32 | ;; equal-to validator 33 | (deftest equal-to-validator-test () 34 | (let ((validator (make-instance 'equal-to-validator :object 22))) 35 | (is (validate validator 22)) 36 | (is (funcall validator 22)) 37 | (is (not (funcall validator 33))) 38 | (multiple-value-bind (result message) 39 | (funcall validator 33) 40 | (declare (ignore result)) 41 | (is (equalp message (validator-message validator 33)))))) 42 | 43 | ;; one-of-validator 44 | (deftest one-of-validator-test () 45 | (let ((validator (make-instance 'one-of-validator :options (list "foo" "bar")))) 46 | (is (funcall validator "foo")) 47 | (is (funcall validator "bar")) 48 | (is (not (funcall validator "bye"))))) 49 | 50 | ;; blank validator 51 | (deftest blank-validator-test () 52 | (let ((validator (make-instance 'blank-validator))) 53 | (is (not (funcall validator "foo"))) 54 | (is (funcall validator "")) 55 | (is (funcall validator nil)))) 56 | 57 | ;; not-blank validator 58 | (deftest not-blank-validator-test () 59 | (let ((validator (make-instance 'not-blank-validator))) 60 | (is (funcall validator "foo")) 61 | (is (not (funcall validator ""))) 62 | (is (not (funcall validator nil))))) 63 | 64 | ;; type validator 65 | 66 | (deftest type-validator-test () 67 | (let ((validator (make-instance 'type-validator :type 'string))) 68 | (is (not (funcall validator 2))) 69 | (is (funcall validator "hello"))) 70 | 71 | (let ((validator (make-instance 'type-validator :type 'boolean))) 72 | (is (funcall validator nil)) 73 | (is (funcall validator t)) 74 | (is (not (funcall validator "hello")))) 75 | 76 | (let ((validator (make-instance 'type-validator :type 'integer))) 77 | (is (funcall validator 22)) 78 | (is (not (funcall validator "hello"))))) 79 | 80 | ;; string validator 81 | (deftest string-validator-test () 82 | (let ((validator (make-instance 'string-validator))) 83 | (is (funcall validator "lala")) 84 | (is (not (funcall validator 22))) 85 | (is (not (funcall validator t))))) 86 | 87 | ;; boolean validator 88 | (deftest boolean-validator-test () 89 | (let ((validator (make-instance 'boolean-validator))) 90 | (is (not (funcall validator "lala"))) 91 | (is (not (funcall validator 22))) 92 | (is (funcall validator t)) 93 | (is (funcall validator nil)))) 94 | 95 | ;; integer validator 96 | (deftest integer-validator-test () 97 | (let ((validator (make-instance 'integer-validator))) 98 | (is (not (funcall validator "asdf"))) 99 | (is (funcall validator 22)) 100 | (is (not (funcall validator t))))) 101 | 102 | ;; symbol validator 103 | (deftest symbol-validator-test () 104 | (let ((validator (make-instance 'symbol-validator))) 105 | (is (not (funcall validator "lala"))) 106 | (is (not (funcall validator 22))) 107 | (is (funcall validator t)) 108 | (is (funcall validator 'foo)) 109 | (is (funcall validator :foo)))) 110 | 111 | ;; keyword validator 112 | (deftest keyword-validator-test () 113 | (let ((validator (make-instance 'keyword-validator))) 114 | (is (not (funcall validator "lala"))) 115 | (is (not (funcall validator 22))) 116 | (is (not (funcall validator t))) 117 | (is (not (funcall validator 'foo))) 118 | (is (funcall validator :foo)))) 119 | 120 | ;; function validator 121 | (deftest function-validator-test () 122 | (let ((validator 123 | (make-instance 'function-validator 124 | :function (lambda (x) 125 | (equalp x 22)) 126 | :message (lambda (validator object) 127 | (declare (ignore validator)) 128 | (format nil "~A is not 22" object))))) 129 | (is (funcall validator 22)) 130 | (is (not (funcall validator 33))))) 131 | 132 | ;; true validator 133 | (deftest true-validator-test () 134 | (let ((validator (make-instance 'true-validator))) 135 | (is (funcall validator t)) 136 | (is (not (funcall validator "lala"))) 137 | (is (not (funcall validator nil))))) 138 | 139 | ;; false validator 140 | (deftest false-validator-test () 141 | (let ((validator (make-instance 'false-validator))) 142 | (is (not (funcall validator t))) 143 | (is (not (funcall validator "lala"))) 144 | (is (funcall validator nil)))) 145 | 146 | ;; less than validator 147 | (deftest less-than-validator-test () 148 | (let ((validator (make-instance 'less-than-validator :number 22))) 149 | (is (funcall validator 21)) 150 | (is (not (funcall validator 32))))) 151 | 152 | ;; greater than validator 153 | (deftest greater-than-validator-test () 154 | (let ((validator (make-instance 'greater-than-validator :number 22))) 155 | (is (not (funcall validator 21))) 156 | (is (funcall validator 32)))) 157 | 158 | ;; not validator 159 | (deftest not-validator-test () 160 | (let ((validator (make-instance 'not-validator :validator (make-instance 'not-blank-validator)))) 161 | (is (not (funcall validator "hello"))) 162 | (is (funcall validator ""))) 163 | 164 | (let ((validator (make-instance 'not-validator :validator (make-instance 'blank-validator)))) 165 | (is (funcall validator "hello")) 166 | (is (not (funcall validator ""))))) 167 | 168 | ;; and validator 169 | (deftest and-validator-test () 170 | (let ((validator (make-instance 'and-validator 171 | :x (make-instance 'greater-than-validator :number 10) 172 | :y (make-instance 'less-than-validator :number 20)))) 173 | (is (not (funcall validator 33))) 174 | (is (funcall validator 15)) 175 | (is (not (funcall validator 9))))) 176 | 177 | ;; or validator 178 | (deftest or-validator-test () 179 | (let ((validator (make-instance 'or-validator 180 | :x (make-instance 'greater-than-validator :number 20) 181 | :y (make-instance 'less-than-validator :number 10)))) 182 | (is (funcall validator 33)) 183 | (is (not (funcall validator 15))) 184 | (is (funcall validator 9)))) 185 | 186 | ;; email validator 187 | (deftest email-validator-test () 188 | (let ((validator (make-instance 'email-validator))) 189 | (is (funcall validator "mariano@gmail.com")) 190 | (is (not (funcall validator "lala"))) 191 | (is (not (funcall validator "@asdf.com"))))) 192 | 193 | ;; regex validator 194 | (deftest regex-validator-test () 195 | (let ((validator (make-instance 'regex-validator :regex "^foo.*$"))) 196 | (is (funcall validator "foo lala")) 197 | (is (not (funcall validator " foo lala"))))) 198 | 199 | ;; url validator 200 | (deftest url-validator-test () 201 | (let ((validator (make-instance 'url-validator))) 202 | (is (not (funcall validator "localhost"))) 203 | (is (not (funcall validator "google.com"))) 204 | (is (funcall validator "http://www.google.com")))) 205 | 206 | ;; length validator 207 | (deftest length-validator-test () 208 | (let ((validator (make-instance 'length-validator :min 5))) 209 | (is (not (funcall validator "lala"))) 210 | (is (funcall validator "foobar")) 211 | (is (funcall validator "12345"))) 212 | (let ((validator (make-instance 'length-validator :max 5))) 213 | (is (funcall validator "lala")) 214 | (is (not (funcall validator "foobar"))) 215 | (is (funcall validator "12345"))) 216 | (let ((validator (make-instance 'length-validator :min 2 :max 6))) 217 | (is (not (funcall validator "a"))) 218 | (is (funcall validator "foo")) 219 | (is (not (funcall validator "foobarfoo"))))) 220 | 221 | ;; builder tests 222 | ;; || is not supported on ECL 223 | #-ecl 224 | (deftest builders-test () 225 | (let ((validator (not-blank))) 226 | (is (not (funcall validator nil))) 227 | (is (not (funcall validator ""))) 228 | (is (funcall validator "hello"))) 229 | 230 | (let ((validator (&& (greater-than 20) 231 | (less-than 30)))) 232 | (is (funcall validator 25)) 233 | (is (not (funcall validator 15)))) 234 | 235 | (is (funcall (== 100) 100)) 236 | (is (not (funcall (== 100) 90))) 237 | 238 | (let ((validator (|| (&& (greater-than 20) 239 | (less-than 30)) 240 | (|| (&& (greater-than 1) 241 | (less-than 10)) 242 | (== 100))))) 243 | (is (funcall validator 5)) 244 | (is (not (funcall validator 90))) 245 | (is (funcall validator 100)) 246 | (is (funcall validator 25)) 247 | (is (not (funcall validator 50))))) 248 | 249 | ;; bigger example 250 | 251 | (defclass person () 252 | ((fullname :initarg :fullname 253 | :accessor fullname 254 | :initform nil) 255 | (email :initarg :email 256 | :accessor email 257 | :initform nil) 258 | (password :initarg :password 259 | :accessor password 260 | :initform nil))) 261 | 262 | (defun validate-person (person) 263 | (collecting-validation-errors (errors found-p) 264 | (with-signal-validation-errors () 265 | (funcall (not-blank "Fullname is required") (fullname person)) 266 | (funcall (not-blank) (password person) :message "Password is required") 267 | (funcall (~ (blank)) (email person) :message "Email is required") 268 | (funcall (valid-email) (email person))) 269 | (declare (ignore found-p)) 270 | errors)) 271 | 272 | (let ((person (make-instance 'person))) 273 | (validate-person person)) 274 | 275 | ;; validator collection 276 | (deftest validator-collection-test () 277 | (let ((validator (make-instance 'validator-collection :validators 278 | (list (not-blank "Fullname is required") 279 | (fn (lambda (x) 280 | (> (length x) 2)) 281 | "Fullname is too short"))))) 282 | (let ((person (make-instance 'person))) 283 | (signals validation-error 284 | (funcall validator (fullname person)))) 285 | 286 | (let ((person (make-instance 'person :fullname "M"))) 287 | (signals validation-error 288 | (funcall validator (fullname person)))) 289 | 290 | (let ((person (make-instance 'person :fullname "Mariano"))) 291 | (finishes (funcall validator (fullname person)))))) 292 | --------------------------------------------------------------------------------