/
formlets.lisp
165 lines (140 loc) · 7.57 KB
/
formlets.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
(in-package :formlets)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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 hidden (formlet-field) ())
(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)
(make-list (length (fields formlet)) ;;so that elements don't get cut off
:initial-element
(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
(when (and (not (every #'null errors)) error-messages)
(htm (:span :class "general-error"
(dolist (s (car errors))
(htm (:p (str s)))))))
(:form :name (string-downcase name) :id (string-downcase 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 (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 ((field hidden) &optional value error)
(html-to-str (:input :name (name field) :value value :type "hidden")))
(defmacro define-show (field-type &body body)
`(defmethod show ((field ,field-type) &optional value error)
(html-to-str
(:li (:span :class "label" (str (string-capitalize (regex-replace-all "-" (name field) " "))))
,@body
(when error (htm (:span :class "formlet-error"
(dolist (s error)
(htm (:p (str s)))))))))))
(define-show formlet-field (:input :name (name field) :value value :class "text-box"))
(define-show textarea (:textarea :name (name field) (str value)))
(define-show password (:input :name (name field) :type "password" :class "text-box"))
(define-show file (:input :name (name field) :type "file" :class "file"))
(define-show select
(:select :name (name field)
(loop for v in (value-set field)
do (htm (:option :value v :selected (when (string= v value) "selected") (str v))))))
(define-show checkbox
(:input :type "checkbox" :name (name field) :value (name field)
:checked (when (string= (name field) value) "checked")))
(define-show radio-set
(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)))))
(define-show multi-select
(: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))))))
(define-show checkbox-set
(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)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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) (and (car val) (> 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))