Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 280 lines (264 sloc) 13.277 kb
f8a6c87f »
2008-09-25 importing the current leftparen
1 #lang scheme/base
2
3 (require (file "util.scm")
4 (file "repository.scm")
5 (file "record.scm")
6 (file "closures.scm")
7 (file "web-support.scm")
9e5c92ef »
2008-10-18 Uploaded files now retain their filename are saved in a private locat…
8 (file "files.scm")
f8a6c87f »
2008-09-25 importing the current leftparen
9 "settings.scm"
10 (lib "url.ss" "net"))
11
12 (provide form
13 form-id
14 form-markup
15 grab-user-input
16 make-field-type
17 field-value-lift
18 default-error-wrapper
19 )
20
21 (define-struct form-obj (markup id))
22 (define form-id form-obj-id)
23 (define form-markup form-obj-markup)
24
25 ;; the call-back : bindings-from-form -> content
26 ;; does not save any records
27 (define (grab-user-input fields call-back
28 #:submit-label (submit-label "Submit")
29 #:init (init '())
30 #:skip-br (skip-br #f)
31 #:stay-on-same-page (stay-on-same-page #f))
32 (form fields
33 #:on-done (lambda (r) (call-back (rec-data r)))
34 #:stay-on-same-page stay-on-same-page
35 #:submit-label submit-label
36 #:skip-save #t
37 #:skip-br skip-br
38 #:init init))
39
40 ;;
41 ;; form
42 ;;
43 ;; Example:
44 ;;
45 ;; (form '((title "Title" text) (content "Post" long-text))
46 ;; #:init '((type . meta-made-data) (kind . text))
47 ;; #:submit-label "Add post"
48 ;; #:before-save (lambda (r) ...)
49 ;; #:on-done (lambda (r) "all done"))
50 ;;
51 ;; * fields: a list of lists. each sublist is of the form (title "Title" text).
52 ;; the field name (the first elt of the sub-list) must
53 ;; match what you want the prop name of the record to be.
54 ;; * init: same form as previous, but provide fixed/default values for record props.
55 ;; You also can use init as a way of "editing". This happens if you provide
56 ;; init values for fields of the form.
57 ;; You can also provide a record to init in which case the record is used instead
58 ;; of making a fresh one.
59 ;; * submit-label: the label for the submit button of the form.
60 ;; * before-save: a fn : rec -> / which lets you do something with r before it's saved.
61 ;; this is run even if skip-save=#t.
62 ;; * on-done: this is a fn : rec -> content
63 ;; * skip-save: set to #t if you don't want to save (on-done thunk is still executed)
64 ;; * fail: a fn; if evals to non-#f, then return it as the answer.
65 ;; * validate: like fail, but if returns a non-#f value then stick it in a div above
66 ;; the form, re-populating the form with what you typed in (i.e., fn should return
67 ;; an error message).
68 ;; * use-if-exists: if set to a property name, then don't create a fresh record
69 ;; if there's already one that's equal to it. (XXX bad name)
70 ;; * stamp-user: if a rec is given then assume it's a user rec and stamp it on the record
71 ;; in the created-by property.
72 ;; * stamp-time: if non-#f, then stamp the current time for the created_at property.
73 ;; default is #t
74 ;; * return-form-obj: returns a form struct instead of raw form markup.
75 ;;
76 ;; "form" is defined just below "form-aux".
77 (define (form-aux fields
78 #:recur recur ; provided automatically by form
79 #:init (init '())
80 #:submit-label (submit-label "Save")
81 #:before-save (before-save (lambda (r) 'done))
82 #:skip-save (skip-save #f)
83 #:stamp-user (stamp-user #f)
84 #:stamp-time (stamp-time #t)
85 #:stay-on-same-page (stay-on-same-page #f)
86 #:fail (fail (lambda (rec) #f))
87 #:validate (validate (lambda (rec) #f))
88 #:error-wrapper (error-wrapper default-error-wrapper)
89 #:error-msg (error-msg #f)
90 #:on-submit (on-submit #f) ; #f or a JS string
91 #:use-if-exists (use-if-exists #f)
92 #:skip-br (skip-br #f)
93 #:class (css-class #f)
6dd8b17e »
2009-01-05 added action parameter
94 #:action (action "/")
f8a6c87f »
2008-09-25 importing the current leftparen
95 #:auto-submit (auto-submit #f)
96 #:return-form-obj (return-form-obj #f)
97 #:on-done (on-done (lambda (rec) (redirect-to (setting *WEB_APP_URL*)))))
98 (let ((init-data (if (rec? init) (rec-data init) init))
99 (is-upload (has-upload-field? fields)))
100 ;; attempt to save the rec that's presumably in the request as generated by the form:
101 (define (store-form-rec! req)
9e5c92ef »
2008-10-18 Uploaded files now retain their filename are saved in a private locat…
102 (let* ((bindings (bindings/string req))
f8a6c87f »
2008-09-25 importing the current leftparen
103 ;; note that if a field is specified but not present in bindings,
104 ;; it gets a #f assigned to it:
105 (relevant-req-bindings
106 (map (match-lambda ((list name label type)
1819cb29 »
2008-11-09 style updates; using a different default name for the file upload dir…
107 (cons name
108 (field-value-lift (find-binding
109 (symbol->string name) bindings)
110 type))))
f8a6c87f »
2008-09-25 importing the current leftparen
111 fields))
112 (data (alist-merge init-data relevant-req-bindings))
113 (a-rec (if (rec? init)
114 (update-edited-rec-with-merge! init data fields)
115 (fresh-rec-from-data data #:stamp-time stamp-time)))
116 (the-rec (or (and use-if-exists
117 (load-one-where
118 `((,use-if-exists . ,(rec-prop a-rec use-if-exists)))))
119 a-rec)))
120 (when stamp-user (rec-set-rec-prop! the-rec 'created-by stamp-user))
121 (or (fail the-rec)
122 (aand (validate the-rec)
123 (let ((form-meat (recur #:init (append relevant-req-bindings init)
124 #:error-msg it)))
125 (error-wrapper (if (form-obj? form-meat)
126 (form-markup form-meat)
127 form-meat))))
128 (begin (before-save the-rec)
129 (unless skip-save (store-rec! the-rec))
130 (let ((finally (on-done the-rec)))
131 (if stay-on-same-page
132 (e "feature missing")
133 finally))))))
134 (let* ((form-id (number->string (random 1000000)))
135 (f `(form
6dd8b17e »
2009-01-05 added action parameter
136 ((action ,action)
f8a6c87f »
2008-09-25 importing the current leftparen
137 (id ,form-id)
138 ,@(splice-if css-class `(class ,css-class))
139 (method "post")
140 ;; XXX see this if pattern?
141 ,@(if is-upload '((enctype "multipart/form-data")) '())
142 ,@(if on-submit `((onsubmit ,on-submit)) '()))
143 ,@(splice-if error-msg `(div ((class "errors")) ,error-msg))
144 (input ((type "hidden")
145 (name ,(symbol->string (setting *CLOSURE_URL_KEY*)))
146 (value ,(body-as-closure-key (req) (store-form-rec! req)))))
147 ,@(form-body fields submit-label init-data form-id
148 #:skip-br skip-br #:auto-submit auto-submit))))
149 (if return-form-obj (make-form-obj f form-id) f))))
150
151 (define form (make-recursive-keyword-version-of-fn form-aux "recur"))
152
153 ;; we refresh the rec-to-edit in case, e.g., a comment has come in.
154 ;; we only update the relevant fields too (so we don't, e.g., overwrite a comment
155 ;; that came in in the meanwhile.)
156 (define (update-edited-rec-with-merge! rec-to-edit new-data fields)
157 (let ((field-names (map first fields)))
158 (rec-set-each-prop! (refresh rec-to-edit)
159 (filter (lambda (k.v) (memq (car k.v) field-names))
160 new-data))))
161
162 (define (has-upload-field? fields)
163 (any (lambda (f) (eq? (last f) 'image)) fields))
164
165 ;;
166 ;; paint-field
167 ;;
168 ;; Note that field-value is a "lifted" (Scheme) value.
169 ;;
170 (define (paint-field field-name field-type form-id
171 #:field-value (field-value #f) #:auto-submit (auto-submit #f))
172 (let ((field-name (symbol->string field-name))
173 (field-type-name (if (field-type? field-type)
174 (field-type-name field-type)
175 field-type))
176 (auto '(onchange "this.form.submit();")))
177 (case field-type-name
178 ((text)
179 `(input ((type "text") (name ,field-name) (class "text-input") (size "40")
180 (value ,(or field-value "")))))
181 ((long-text)
182 `(textarea ((name ,field-name) (class "text-input")
183 (cols "20") (rows "4")) ,(or field-value "")))
184 ((number)
185 `(input ((type "text") (name ,field-name) (size "5") (class "text-input")
186 (value ,(or (and field-value (number->string field-value)) "")))))
187 ((password)
188 `(input ((type "password") (class "text-input") (name ,field-name))))
189 ((image)
190 `(input ((type "file") (name ,field-name))))
191 ((checkbox)
192 (if field-value ; then it is checked
193 `(span (input ((type "checkbox") (checked "yup") (name ,field-name)
194 (class "checkbox")
195 ,@(splice-if auto-submit auto)))
196 (input ((type "hidden") (name ,field-name) (value "off"))))
197 `(input ((type "checkbox") (name ,field-name) (class "checkbox")
198 ,@(splice-if auto-submit auto)))))
199 ((radio)
200 (generic-picker (field-type-params field-type)
201 (lambda (val disp is-selected)
202 `(tr (td (input ((type "radio") (name ,field-name) (value ,val)
203 ,@(if is-selected `((checked "yup")) '()))))
204 (td ,@disp)))
205 (lambda (elts) `(table ((class "big-radio")) ,@elts))
206 #:current-pick field-value))
207 ((drop-down)
208 `(group ,(generic-picker (field-type-params field-type)
209 (lambda (val disp is-selected)
210 `(option ((value ,val)
211 ,@(if is-selected `((selected "yup")) '()))
212 ,disp))
213 (lambda (elts) `(select ((name ,field-name)) ,@elts))
214 #:current-pick field-value)
215 (br)))
216 (else (error (format "Field type '~A' for field '~A' not understood."
217 field-type field-name))))))
218
219 ;; elt-wrapper : val-str X display X is-selected -> content
220 ;; whole-wrapper : list(elt-content) -> content
221 (define (generic-picker sym.=>display elt-wrapper whole-wrapper
222 #:current-pick (current-pick #f))
223 (whole-wrapper (map (match-lambda ((list-rest sym disp)
224 (elt-wrapper (symbol->string sym)
225 disp
226 (eq? sym current-pick))))
227 sym.=>display)))
228
229 ;; go from form value to Scheme value
230 (define (field-value-lift field-val field-type)
1819cb29 »
2008-11-09 style updates; using a different default name for the file upload dir…
231 (cond
232 ;; checkbox?
233 ((and (equal? field-type 'checkbox) (binding/string:form? field-val))
234 (if (equal? (binding/string:form-value field-val) "on") #t #f))
235 ;; number?
236 ((and (equal? field-type 'number) (binding/string:form? field-val))
237 (string->number (binding/string:form-value field-val)))
238 ;; image?
239 ((and (equal? field-type 'image) (binding/string:file? field-val))
240 (save-uploaded-file-and-return-filename! field-val))
241 ;; else
242 (else (if (and (binding/string:form? field-val)
243 (string=? (binding/string:form-value field-val) ""))
244 #f
245 (binding/string:form-value field-val)))))
f8a6c87f »
2008-09-25 importing the current leftparen
246
247 (define (paint-rich-text-editor field-name field-value form-id)
248 `(div ((class "yui-skin-sam"))
249 (textarea ((name ,field-name) (id ,field-name) (cols "50") (rows "10"))
250 ,field-value)
251 (script ,(format "render_rich_text_editor('~A', '~A')" field-name form-id))))
252
253 ;; returns a list of html objects, so you'll need to splice in to the caller.
254 (define (form-body fields submit-label init-data form-id
255 #:skip-br (skip-br #f) #:auto-submit (auto-submit #f))
256 (define (paint-segment field-name display-name field-type)
257 (let* ((is-checkbox (eq? field-type 'checkbox))
258 (lbl-inp-lst (list (if is-checkbox
259 display-name
260 `(label ,display-name))
261 (paint-field field-name field-type form-id
262 #:field-value (assoc-val field-name init-data)
263 #:auto-submit auto-submit)
264 (if skip-br "" '(br)))))
265 ;; we want the checkbox to come before the label:
266 (when (and is-checkbox display-name (or (not (string? display-name))
267 (not (string=? display-name ""))))
268 (set! lbl-inp-lst (cons-to-end '(br) (reverse lbl-inp-lst))))
269 `(group ,@lbl-inp-lst)))
270 (append
271 (map (match-lambda ((list field-name display-name field-type)
272 (paint-segment field-name display-name field-type)))
273 fields)
274 `((input ((type "submit") (value ,submit-label))))))
275
276 (define-struct field-type (name params))
277
278 (define (default-error-wrapper form-meat)
279 form-meat)
Something went wrong with that request. Please try again.