Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

some validation tools

  • Loading branch information...
commit 828e568245355c92e2bb34bf5bfd8119bf317555 1 parent 86b190d
@mishoo authored
View
67 json-validation.lisp
@@ -0,0 +1,67 @@
+(in-package #:sytes)
+
+(define-condition rpc-error-validation (rpc-error) ())
+
+(defmethod json:encode-json ((e rpc-error-validation) &optional stream)
+ (json:encode-json (json-hash `((code . ,(code e))
+ (text . ,(text e))
+ (info . ,(info e))))
+ stream))
+
+(export 'validate-fields)
+(defmacro validate-fields (&body fields)
+ (let ((errors (gensym))
+ (ex (gensym)))
+ `(let ((,errors nil))
+ ,@(loop for (field . args) in fields collect
+ `(handler-case (validate ,field ,@args :field-name ',field)
+ (rpc-error-validation (,ex)
+ (push ,ex ,errors))))
+ (when ,errors
+ (error 'rpc-error
+ :text "Validation error"
+ :code "VALIDATION"
+ :info (reverse ,errors))))))
+
+(defgeneric validate (field how
+ &rest args
+ &key text code field-name info
+ &allow-other-keys))
+
+(defmethod validate ((field string) (how (eql :required))
+ &key
+ (text "This field is required")
+ (code :bad-data)
+ field-name
+ (info field-name))
+ (validate field "\\S" :text text :code code :info info :field-name field-name))
+
+(defmethod validate ((field null) (how (eql :required))
+ &key
+ (text "This field is required")
+ (code :bad-data)
+ field-name
+ (info field-name))
+ (error 'rpc-error-validation :text text :code code :info info))
+
+(defmethod validate (field (how (eql :required)) &key &allow-other-keys)
+ t)
+
+(defmethod validate ((field string) (regex string)
+ &key (text "Validation error") (code :bad-data)
+ field-name (info field-name))
+ (unless (ppcre:scan regex field)
+ (error 'rpc-error-validation :text text :code code :info info)))
+
+(defmethod validate ((field string) (how (eql :email))
+ &key
+ (text "This doesn't look like an email address")
+ (code :bad-data)
+ field-name
+ (info field-name))
+ (validate field "^$|^([^@\\n\\r,]+)@((?:[-a-z0-9]+\\.)+[a-z]{2,})$"
+ :text text :code code :info info))
+
+(defmethod validate ((field null) (how (eql :email)) &key &allow-other-keys)
+ t)
+
View
12 json.lisp
@@ -86,10 +86,14 @@
for ret = (let ((*json-notify-before* nil)
(*json-notify-after* nil)
(func (gethash (string-upcase cmd) (syte-json-handlers syte))))
- (prog1
- (vector id cmd (apply func args))
- (setf before *json-notify-before*
- after *json-notify-after*)))
+ (vector id cmd
+ (handler-case
+ (prog1
+ (apply func args)
+ (setf before *json-notify-before*
+ after *json-notify-after*))
+ (rpc-error (ex)
+ ex))))
when before nconc it
collect ret
when after nconc it)))
View
5 sytes+json.asd
@@ -6,5 +6,8 @@
:depends-on (#:sytes
#:local-time
#:cl-json
+ #:cl-ppcre
+ #:cl-ppcre-unicode
#:trivial-backtrace)
- :components ((:file "json")))
+ :components ((:file "json")
+ (:file "json-validation")))
View
30 template/compiler.lisp
@@ -223,6 +223,7 @@
(def-primitive "null?" #'null)
(def-primitive "member" (lambda (item list &key (test #'das-eq))
(member item list :test test)))
+(def-primitive "vector" #'vector)
(def-primitive "rplaca" #'rplaca)
(def-primitive "rplacd" #'rplacd)
@@ -366,13 +367,17 @@
(apply func args))))
(labels ((strcat (args out)
- (dolist (a args)
- (when a
- (typecase a
- (string (write-string a out))
- (character (write-char a out))
- (list (strcat a out))
- (t (format out "~A" a)))))))
+ (typecase args
+ (list (dolist (a args)
+ (when a
+ (typecase a
+ (string (write-string a out))
+ (character (write-char a out))
+ (list (strcat a out))
+ (t (format out "~A" a))))))
+ (string (write-string args out))
+ (character (write-char args out))
+ (t (format out "~A" args)))))
(def-primitive "strcat"
(lambda (&rest args)
(with-output-to-string (out)
@@ -409,7 +414,16 @@
(def-primitive "esc"
(lambda (&rest args)
(tbnl:escape-for-html (with-output-to-string (out)
- (strcat args out))))))
+ (strcat args out)))))
+
+ (def-primitive "join"
+ (lambda (separator list)
+ (with-output-to-string (out)
+ (loop for i in list
+ for first = t then nil
+ unless first
+ do (strcat separator out)
+ do (strcat i out))))))
(def-primitive "sort" #'stable-sort)
Please sign in to comment.
Something went wrong with that request. Please try again.