-Massive friggin changes (all old features are still supported, it has been thoroughly tested and the test facility is included, minus reCaptcha keys) check README.md for details on what's new

Author: ingram

README.md

@@ -0,0 +1,11 @@
+(defpackage :formlets-test-system (:use :cl :asdf))
+(in-package :formlets-test-system)
+(defsystem formlets-test
+  :version "0.1"
+  :author "leo.zovic@gmail.com"
+  :maintainer "leo.zovic@gmail.com"
+  :licence "MIT-style"
+  :description "Testing system to simplify development of the validating formlets system for Hunchentoot"
+  :components ((:file "test-package")
+	       (:file "test" :depends-on ("test-package")))
+  :depends-on (:cl-who :drakma :hunchentoot :cl-ppcre :formlets))

formlets-test.asd

@@ -20,7 +20,7 @@
 ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
 ;; THE SOFTWARE.
 
-(defpackage "FORMLETS-SYSTEM" (:use :cl :asdf))
+(defpackage :formlets-system (:use :cl :asdf))
 (in-package :formlets-system)
 (defsystem formlets
   :version "0.1"
@@ -30,6 +30,7 @@
   :description "Validating formlets for Hunchentoot"
   :components ((:file "package")
 	       (:file "utility" :depends-on ("package"))
-	       (:file "recaptcha" :depends-on ("package" "utility"))
-	       (:file "formlets" :depends-on ("package" "utility" "recaptcha")))
+	       (:file "formlets" :depends-on ("package" "utility"))
+	       (:file "recaptcha" :depends-on ("package" "utility" "formlets"))
+	       (:file "macros" :depends-on ("package" "utility" "formlets")))
   :depends-on (:cl-who :drakma :hunchentoot :cl-ppcre))

formlets.asd

@@ -1,84 +1,171 @@
 (in-package :formlets)
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Predicates
-;;;;;;;;;;;;;;;basic field predicates
-(defun longer-than? (num) (lambda (f) (> (length f) num)))
-(defun shorter-than? (num) (lambda (f) (< (length f) num)))
-(defun matches? (regex) (lambda (f) (scan regex f)))
-(defun mismatches? (regex) (lambda (f) (not (scan regex f))))
-
-;;;;;;;;;;;;;;;file-related
-;; a hunchentoot file tuple is '(temp-filename origin-filename file-mimetype)
-(defun file-type? (&rest accepted-types)
-  (lambda (hunchentoot-file-tuple) 
-    (member (third hunchentoot-file-tuple) accepted-types :test #'equal)))
-
-(defun file-smaller-than? (byte-size)
-  (lambda (hunchentoot-file-tuple) 
-    (> byte-size (file-size (car hunchentoot-file-tuple)))))
-
-;;;;;;;;;;;;;;;recaptcha
-(defun validate-recaptcha ()
-  (recaptcha-passed? (post-parameter "recaptcha_challenge_field") (post-parameter "recaptcha_response_field") (real-remote-addr)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;View related functions
-(defun show-form-field (name type form-values form-errors)
-  (let* ((s-name (string name)) (l-name (string-downcase s-name)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CLASS DECLARATIONS
+(defclass formlet ()
+  ((name			 :reader name			:initarg :name)
+   (fields			 :reader fields			:initarg :fields)
+   (validation-functions 	 :accessor validation-functions :initarg :validation-functions	 :initform nil)
+   (error-messages	 	 :reader error-messages		:initarg :error-messages 	 :initform nil)
+   (submit-caption		 :reader submit			:initarg :submit		 :initform "Submit")
+   (enctype			 :accessor enctype		:initarg :enctype		 :initform "application/x-www-form-urlencoded")
+   (on-success			 :reader on-success		:initarg :on-success)))
+
+(defclass formlet-field ()
+  ((name			:reader name			:initarg :name)
+   (validation-functions	:accessor validation-functions	:initarg :validation-functions	:initform nil)
+   (default-value		:reader default-value		:initarg :default-value		:initform nil)
+   (error-messages		:accessor error-messages	:initarg :error-messages	:initform nil)))
+
+(defclass text (formlet-field) ())
+(defclass textarea (formlet-field) ())
+(defclass password (formlet-field) ())
+(defclass file (formlet-field) ())
+(defclass checkbox (formlet-field) ())
+
+(defclass formlet-field-set (formlet-field)
+  ((value-set :reader value-set :initarg :value-set :initform nil))
+  (:documentation "This class is for fields that show the user a list of options"))
+
+(defclass select (formlet-field-set) ())
+(defclass radio-set (formlet-field-set) ())
+
+(defclass formlet-field-return-set (formlet-field-set) ()
+  (:documentation "This class is specifically for fields that return multiple values from the user"))
+
+(defclass multi-select (formlet-field-return-set) ())
+(defclass checkbox-set (formlet-field-return-set) ())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; METHODS
+;;;;;;;;;;post-value
+;;;;NOTE:   This section exists because Hunchentoots' (post-parameter [field-name])
+;;        returns a single value. This is problematic for multi-select boxes and checkbox sets
+;;        (both of which potentially return multiple values from the user).
+;;          post-value is not necessarily Hunchentoot specific, but it does expect values in the form of an alist
+
+(defmethod post-value ((formlet formlet) post-alist)
+  (mapcar (lambda (f) (post-value f post-alist)) (fields formlet)))
+
+(defmethod post-value ((field formlet-field) post-alist)
+  (cdr (assoc (name field) post-alist :test #'string=)))
+
+(defmethod post-value ((field formlet-field-return-set) post-alist)
+  (loop for (k . v) in post-alist
+	if (string= k (name field)) collect v))
+  
+;;;;;;;;;;validate
+;;;;;NOTE: The validate methods each return (values [validation result] [errors]). 
+;;         [validation result] is a boolean
+;;         [errors] can be either a list or tree of strings
+
+(defmethod validate ((formlet formlet) form-values)
+  (let ((errors (if (validation-functions formlet)
+		    (loop for f in (validation-functions formlet)
+			  for msg in (error-messages formlet)
+			  unless (apply f form-values) collect msg)
+		    (loop for f in (fields formlet)
+			  for v in form-values
+			  collect (multiple-value-bind (result error) (validate f v) (unless result error))))))
+    (values (every #'null errors) errors)))
+
+(defmethod validate ((field formlet-field) value)
+  "Returns (values T NIL) if there are no errors, and (values NIL list-of-errors). 
+   By default, a formlet-field passes only its own value to its validation functions."
+  (let ((errors (loop for fn in (validation-functions field)
+		      for msg in (error-messages field)
+		      unless (funcall fn value) collect msg)))
+    (values (every #'null errors) errors)))
+
+;;;;;;;;;;show
+;;;; The show functions just take a formlet/(-field)?/ (along with its value/s?/ and error/s?/)
+;;   and output the corresponding HTML. This part is cl-who specific, but it could be easily made portable
+;;   by replacing html-to-stout and html-to-str with raw format calls
+
+(defmethod show ((formlet formlet) &optional values errors)
+  (with-slots (error-messages name enctype) formlet
     (html-to-stout
-      (:li (:span :class "label" (str (name->label name)))
-	   (case type 
-	     (:textarea (htm (:textarea :name l-name (str (getf form-values (sym->keyword name))))))
-	     (:password (htm (:input :name l-name :class "text-box" :type (string type))))
-	     (:file (htm (:input :name l-name :class "file" :type (string type))))
-	     (:recaptcha (htm (recaptcha)))
-	     (otherwise (htm (:input :name l-name 
-				     :value (getf form-values (sym->keyword name))
-				     :class "text-box" :type (string type)))))
-	   (show-error form-errors (sym->keyword name))))))
-
-(defmacro show-form ((form-name values errors &key (submit "Submit") (enctype "application/x-www-form-urlencoded")) &body fields)
-  (let ((n (string-downcase (string form-name))))
-    `(html-to-stout
-       (show-general-error ,errors)
-       (:form :name ,n :id ,n :action ,(string-downcase (format nil "/validate-~a" n)) :enctype ,enctype :method "post"
-	      (:ul :class "form-fields"
-		   ,@(mapcar (lambda (field) 
-			       `(show-form-field ',(car field) ',(cadr field) ,values ,errors))
-			     fields)
-		   (:li (:span :class "label") (:input :type "submit" :class "submit" :value ,submit)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Validation related functions
-(defmacro validate-form ((origin-fn &key fields general) &body on-success)
-  `(let ((results (list ,@(loop for (field-name field-type . fn/message-list) in fields
-			     collect (sym->keyword field-name)
-			     collect (validate-field field-name field-type fn/message-list general)))))
-     (if (all-valid? results)
-	 (progn ,@on-success)
-	 (,origin-fn :form-values (list ,@(loop for field in fields 
-					     unless (member (cadr field) '(:password :file :recaptcha))
-					     collect (sym->keyword (car field)) and collect (car field)))
-		     :form-errors ,(if general `(list :general-error ,general) 'results)))))
-
-(defun validate-field (field-value field-type fn/message-list general-error-message)
-  (cond ((equalp :recaptcha field-type) `(unless (validate-recaptcha) "You seem to have mistyped the recaptcha"))
-	((null fn/message-list) nil)
-	(general-error-message `(unless (funcall ,(car fn/message-list) ,field-value) ,general-error-message))
-	((= 2 (length fn/message-list)) `(unless (funcall ,(car fn/message-list) ,field-value) ,(cadr fn/message-list)))
-	(t `(combine-errors (loop for (val-fn error-message) on (list ,@fn/message-list) by #'cddr
-			       collect (unless (funcall val-fn ,field-value) error-message))))))
-	
-(defun combine-errors (list-of-errors)
-  (when (remove-if #'null list-of-errors) 
-    (html-to-str 
-      (dolist (e list-of-errors)
-	(when e (htm (:p (str e))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Formlet definition
-(defmacro def-formlet (formlet-name (source-fn fields &key general submit) &body on-success)
-  (let* ((enctype "application/x-www-form-urlencoded")
-	 (name+type (loop for f in fields collecting (list (car f) (cadr f)) when (equalp (cadr f) :file) do (setf enctype "multipart/form-data")))
-	 (f-names (mapcar #'car fields)))
-    `(progn (defun ,(intern (format nil "SHOW-~a-FORM" formlet-name)) (values errors)
-	      (show-form (,formlet-name values errors :submit ,submit :enctype ,enctype) ,@name+type))
-	    (define-easy-handler (,(intern (format nil "VALIDATE-~a" formlet-name)) :uri ,(format nil "/validate-~(~a~)" formlet-name)) ,f-names
-	      (validate-form (,source-fn :fields ,fields :general ,general) ,@on-success)))))
+      (when (and (not (every #'null errors)) error-messages) 
+	(htm (:span :class "general-error" (str (show error-messages)))))
+      (:form :name (name formlet) :id name :action (format nil "/validate-~(~a~)" name) :enctype enctype :method "post"
+	     (:ul :class "form-fields"
+		  (loop for a-field in (fields formlet)
+			for e in errors
+			for v in values
+			do (htm (:li (:span :class "label" (str (string-capitalize (regex-replace-all "-" (name a-field) " "))))
+				     (str (show a-field v (when (and e (not error-messages)) e))))))
+		  (:li (:span :class "label") (:input :type "submit" :class "submit" :value (submit formlet))))))))
+
+(defmethod show ((list-of-string list) &optional v e)
+  "A method for showing error output in the Formlets module"
+  (declare (ignore v e))
+  (when list-of-string
+    (html-to-str (:span :class "formlet-error" (dolist (s list-of-string) (htm (:p (str s))))))))
+
+(defmethod show ((field formlet-field) &optional value error)
+  (html-to-str (:input :name (name field) :value value :class "text-box") (str (show error))))
+
+(defmethod show ((field textarea) &optional value error)
+  (html-to-str (:textarea :name (name field) (str value)) (str (show error))))
+
+(defmethod show ((field password) &optional value error)
+  (html-to-str (:input :name (name field) :type "password" :class "text-box") (str (show error))))
+
+(defmethod show ((field file) &optional value error)
+  (html-to-str (:input :name (name field) :type "file" :class "file") (str (show error))))
+
+(defmethod show ((field select) &optional value error)
+  (html-to-str (:select :name (name field)
+			(loop for v in (value-set field) 
+			      do (htm (:option :value v :selected (when (string= v value) "selected") (str v)))))
+	       (str (show error))))
+
+(defmethod show ((field checkbox) &optional value error)
+  (html-to-str (:input :type "checkbox" :name (name field) :value (name field)
+		       :checked (when (string= (name field) value) "checked"))
+	       (str (show error))))
+
+(defmethod show ((field radio-set) &optional value error)
+  (html-to-str (loop for v in (value-set field)
+		     do (htm (:span :class "input+label" 
+					   (:input :type "radio" :name (name field) :value v 
+						   :checked (when (string= v value) "checked"))
+					   (str v))))
+	       (str (show error))))
+
+
+(defmethod show ((field multi-select) &optional value error)
+  (html-to-str (:select :name (name field) :multiple "multiple" :size 5
+			(loop for v in (value-set field)
+			      do (htm (:option :value v 
+					       :selected (when (member v value :test #'string=) "selected")
+							 (str v)))))
+	       (str (show error))))
+
+(defmethod show ((field checkbox-set) &optional value error)
+  (html-to-str (loop for v in (value-set field)
+		     do (htm (:span :class "input+label"
+					   (:input :type "checkbox" :name (name field) :value v 
+						   :checked (when (member v value :test #'string=) "checked"))
+					   (str v))))
+	       (str (show error))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; PREDICATES
+(defmacro define-predicate (name (&rest args) &body body)
+  `(defun ,name ,args (lambda (val) ,@body)))
+
+;;;;;;;;;; basic field predicates
+(define-predicate longer-than? (num) (> (length val) num))
+(define-predicate shorter-than? (num) (< (length val) num))
+(define-predicate matches? (regex) (scan regex val))
+(define-predicate mismatches? (regex) (not (scan regex val)))
+(define-predicate not-blank? () (or (null val) (and (stringp val) (not (string= "" val)))))
+(define-predicate same-as? (field-name-string) (string= val (post-parameter field-name-string)))
+
+;;;;;;;;;; file-related
+;; a hunchentoot file tuple is '([temp filename] [origin filename] [file mimetype])
+(define-predicate file-type? (&rest accepted-types) (member (third val) accepted-types :test #'equal))
+(define-predicate file-smaller-than? (byte-size) (> byte-size (file-size (car val))))
+
+;;;;;;;;;; set-related
+(define-predicate picked-more-than? (num) (> (length val) num))
+(define-predicate picked-fewer-than? (num) (< (length val) num))
+(define-predicate picked-exactly? (num) (= (length val) num))

formlets.lisp

@@ -0,0 +1,65 @@
+(in-package :formlets)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; HELPER MACROS
+;; NOTE: If you REALLY want, you can define your own raw formlet instance and validator as in define-formlet.
+;;       The same can be said about show-formlet. If you go this route, pay attention to how they communicate;
+;;       currently they use Hunchentoots' session (which is the main reason :formlets isn't portable)
+(defun define-field (field-name field-type &key size value-set default-value validation)
+  "Takes a terse declaration and expands it into a make-instance for macro purposes"
+  (let ((final-value-set (when value-set `(:value-set (list ,@value-set))))
+	(final-size (when size `(:size ,size))))
+    (multiple-value-bind (functions messages) (split-validation-list validation)
+      `(make-instance ',field-type :name ,(format nil "~(~a~)" field-name) 
+		      :default-value ,default-value ,@final-value-set ,@final-size
+		      :validation-functions (list ,@functions) :error-messages (list ,@messages)))))
+
+(defmacro define-formlet ((name &key general-validation (submit "Submit")) (&rest fields) &rest on-success)
+  "Converts a terse declaration form into the corresponding object and validation handler."
+  ;;; the flet function converts a terse declaration into the corresponding make-instance declaration
+  (let* ((field-names (mapcar #'car fields))
+	 (field-objects (mapcar (lambda (f) (apply #'define-field f)) fields))
+	 (enctype (if (every (lambda (f) (not (eq (cadr f) 'file))) fields)
+		      "application/x-www-form-urlencoded" 
+		      "multipart/form-data")))
+    (multiple-value-bind (gen-val-fn gen-err-msg) (split-validation-list general-validation) 
+      `(progn 
+         ;;; declare formlet instance
+	 (defparameter ,name
+	   (make-instance 'formlet
+			  :name ',name :submit ,submit :enctype ,enctype
+			  :validation-functions ,(when general-validation `(list ,@gen-val-fn)) 
+			  :error-messages ,(when general-validation `(list ,@gen-err-msg))
+			  :fields (list ,@field-objects)
+			  :on-success (lambda ,field-names (progn ,@on-success))))
+	 
+         ;;; declare validation handler
+	 (define-easy-handler (,(intern (format nil "VALIDATE-~a" name)) :uri ,(format nil "/validate-~(~a~)" name)) ()
+	   (let* ((formlet-values (post-value ,name (post-parameters*)))
+		  (formlet-return-values (loop for f in (formlets::fields ,name) ;;the values list, less password values
+					       for v in formlet-values
+					       unless (eq (type-of f) 'password) collect v
+						 else collect nil)))
+	     (multiple-value-bind (result errors) (validate ,name formlet-values)
+	       (if result
+		   (apply (formlets::on-success ,name) formlet-values) ;; if everything's ok, send the user on
+		   (progn
+		     (setf (session-value :formlet-values) formlet-return-values
+			   (session-value :formlet-errors) errors
+			   (session-value :formlet-name) ',name)
+		     (redirect (referer)))))))))))
+
+(defmacro show-formlet (formlet-name)
+  "Shortcut for displaying a formlet.
+   It outputs the formlet HTML to standard-out (with indenting).
+   If this is the last submitted formlet in session, display field values and errors, then clear out the formlet-related session information."
+  `(let ((val (if (eq (session-value :formlet-name) ',formlet-name)
+		  (session-value :formlet-values)
+		  (make-list (length (formlets::fields ,formlet-name)))))
+	 (err (if (eq (session-value :formlet-name) ',formlet-name)
+		  (session-value :formlet-errors)
+		  (make-list (length (formlets::fields ,formlet-name))))))
+     (show ,formlet-name val err)
+     (when (eq (session-value :formlet-name) ',formlet-name)
+       (delete-session-value :formlet-name)
+       (delete-session-value :formlet-values)
+       (delete-session-value :formlet-errors))))

macros.lisp

@@ -2,8 +2,9 @@
   (:use :cl :cl-who :hunchentoot)
   (:import-from :cl-ppcre :regex-replace-all :split :scan)
   (:import-from :drakma :http-request)
-  (:export :def-formlet
-	   :recaptcha :recaptcha-passed? :combine-errors :*private-key* :*public-key*
-	   :file-type? :file-smaller-than?
-	   :longer-than? :shorter-than? :matches? :mismatches?)
+  (:export :formlet :formlet-field 
+	   :text :textarea :password :file :checkbox :select :radio-set :checkbox-set :multi-select
+ 	   :*public-key* :*private-key* :recaptcha
+	   :validate :show :post-value :show-formlet :define-formlet
+	   :longer-than? :shorter-than? :matches? :mismatches? :file-type? :file-smaller-than? :not-blank? :same-as? :picked-more-than? :picked-fewer-than? :picked-exactly?)
   (:documentation "A package implementing auto-validating formlets for Hunchentoot"))