├── .gitignore ├── 1forms.asd ├── forms └── form.tmpl ├── LICENSE ├── package.lisp ├── README.md └── 1forms.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* 9 | -------------------------------------------------------------------------------- /1forms.asd: -------------------------------------------------------------------------------- 1 | ;;;; 1forms.asd 2 | 3 | (asdf:defsystem #:1forms 4 | :description "Web forms generator" 5 | :author "Timofei Shatrov " 6 | :license "MIT" 7 | :depends-on (#:cl-markup 8 | #:cl-emb 9 | #:cl-ppcre) 10 | :serial t 11 | :components ((:file "package") 12 | (:file "1forms"))) 13 | 14 | -------------------------------------------------------------------------------- /forms/form.tmpl: -------------------------------------------------------------------------------- 1 | <% @loop errors %> 2 | 3 | <% @var error -escape html %> 4 | 5 | <% @endloop %> 6 | <% @loop allfields %> 7 |
8 | <% @var label %> 9 | <% @loop errors %> 10 | 11 | <% @var error -escape html %> 12 | 13 | <% @endloop %> 14 | <% @var field %> 15 |
16 | <% @endloop %> 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Timofei Shatrov 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage 1forms 4 | (:use :cl :alexandria :cl-markup) 5 | (:export 6 | :field-error 7 | :field-error-field 8 | :field-error-message 9 | :render-field 10 | :field :field-name :field-id :field-prefix :field-label :field-str :field-validator 11 | :input-field :input-type :input-disabled :input-extra 12 | :get-field-id 13 | :input-attrs 14 | :to-lisp 15 | :string-field 16 | :form :form-data :form-errors :form-initials :form-fields 17 | :validate :full-validate 18 | :render-label 19 | :validate-field 20 | :form-boundp 21 | :form-to-plist 22 | :accept-value 23 | :render-form 24 | :def-form 25 | :validate-length 26 | :validate-regex 27 | :password-field 28 | :process-form 29 | :bind-form 30 | :*form-template-directory* 31 | :*default-form-template* 32 | :form-vars 33 | :select-field 34 | :select-choices 35 | :finalize 36 | :hidden-field 37 | :formset 38 | :bind-formset 39 | :render-formset 40 | :def-formset 41 | :spawn-form 42 | :formset-forms 43 | :formset-form-class 44 | :formset-form-initargs 45 | :make-choices 46 | :validate-integer-str 47 | :validator)) 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 1forms 2 | 3 | 1forms is a web form generator for Common Lisp. It is inspired by Django web forms implementation. It can be used with various Common Lisp web servers and web frameworks such as [caveman2](https://github.com/fukamachi/caveman/). 1forms uses CLOS and is extensible by design. 4 | 5 | This project is in early stages and still under development. 6 | 7 | ## Example 8 | 9 | Example of form definition: 10 | 11 | ```cl 12 | (def-form register-form () 13 | (:login string-field 14 | :validator 'validate-login 15 | :name "login" 16 | :label "Username" 17 | ) 18 | (:password password-field 19 | :validator 'validate-password 20 | :name "pw" 21 | :label "Password") 22 | (:fullname string-field 23 | :validator (lambda (str) 24 | (validate-length str 3 255 t)) 25 | :name "fullname" 26 | :label "Full name") 27 | (:email string-field 28 | :validator 'validate-email 29 | :name "email" 30 | :label "Email")) 31 | 32 | (defmethod finalize ((form register-form)) 33 | (let ((data (form-data form))) 34 | (create-user 35 | (getf data :login) 36 | (getf data :password) 37 | :fullname (getf data :fullname "") 38 | :email (getf data :email "")))) 39 | ``` 40 | 41 | Example of form being used: 42 | 43 | ```cl 44 | (let ((form (make-instance 'register-form))) 45 | (bind-form form 'post-params) 46 | (process-form form 47 | ;; if form doesn't validate, display it with errors 48 | (some-template-rendering-function "register.tmpl" 49 | `(:form ,(render-form form))) 50 | ;; if successful 51 | (redirect (url-for 'login)))) 52 | ``` 53 | -------------------------------------------------------------------------------- /1forms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 1forms.lisp 2 | 3 | (in-package :1forms) 4 | 5 | (defun local-path (filename) 6 | (asdf:system-relative-pathname :1forms filename)) 7 | 8 | (defvar *form-template-directory* (local-path "forms/")) 9 | 10 | (defparameter *default-form-template* "form.tmpl") 11 | 12 | (define-condition field-error (error) 13 | ((field :initarg :field :initform nil 14 | :reader field-error-field) 15 | (message :initarg :message 16 | :reader field-error-message)) 17 | (:report (lambda (condition stream) 18 | (format stream "Error in field ~a: ~a" 19 | (field-error-field condition) 20 | (field-error-message condition))))) 21 | 22 | (defclass field () 23 | ((name :initarg :name :initform nil :reader field-name) 24 | (id :initarg :id :initform nil :reader field-id) 25 | (prefix :initarg :prefix :initform "field" :reader field-prefix) 26 | (label :initarg :label :initform nil :reader field-label) 27 | (str-value :initarg :value :initform nil :reader field-str) 28 | (validator :initarg :validator :initform nil :reader field-validator) 29 | )) 30 | 31 | (defgeneric render-field (field &key &allow-other-keys) 32 | (:method (field &key) "")) 33 | 34 | (defgeneric render-label (field) 35 | (:method ((field field)) 36 | (if (field-label field) 37 | (markup (:label :for (get-field-id field) (field-label field))) 38 | ""))) 39 | 40 | (defgeneric get-field-id (field) 41 | (:method ((field field)) 42 | (or (field-id field) 43 | (and (field-name field) 44 | (format nil "~a_~a" (field-prefix field) (field-name field)))))) 45 | 46 | (defgeneric validate-field (field val) 47 | (:method ((field field) val) val)) 48 | 49 | (defmethod validate-field :around ((field field) val) 50 | (if (field-validator field) 51 | (funcall (field-validator field) (call-next-method)) 52 | (call-next-method))) 53 | 54 | (defgeneric accept-value (field val) 55 | (:method ((field field) val) 56 | (if val 57 | (princ-to-string val) 58 | ""))) 59 | 60 | (defclass input-field (field) 61 | ((prefix :initform "input") 62 | (type :initarg :type :reader input-type) 63 | (disabled :initarg :disabled :initform nil :reader input-disabled) 64 | (extra :initarg :extra :initform nil :reader input-extra) 65 | )) 66 | 67 | (defgeneric input-attrs (field) 68 | (:method-combination append) 69 | (:method append ((field input-field)) 70 | (list* :id (get-field-id field) 71 | :name (field-name field) 72 | :type (input-type field) 73 | :disabled (input-disabled field) 74 | (input-extra field)))) 75 | 76 | (defun get-input-attrs (field) 77 | (loop for (attr value) on (input-attrs field) by #'cddr 78 | when value 79 | append (list attr value))) 80 | 81 | (defun write-tag (tag) 82 | (with-output-to-string (s) 83 | (loop for str in (cl-markup::tag->string tag) 84 | do (write-string str s)))) 85 | 86 | (defmethod render-field (field &key value) 87 | (write-tag `(:input ,@(get-input-attrs field) ,@(when value `(:value ,value))))) 88 | 89 | (defgeneric to-lisp (field) 90 | (:documentation "returns lisp value for field or raises field-error for invalid values")) 91 | 92 | (defclass string-field (input-field) 93 | ((type :initform "text"))) 94 | 95 | (defclass password-field (string-field) 96 | ((type :initform "password"))) 97 | 98 | (defclass hidden-field (string-field) 99 | ((type :initform "hidden"))) 100 | 101 | (defmethod to-lisp ((field string-field)) 102 | (field-str field)) 103 | 104 | (defclass select-field (field) 105 | ((prefix :initform "select") 106 | (disabled :initarg :disabled :initform nil :reader input-disabled) 107 | (extra :initarg :extra :initform nil :reader input-extra) 108 | (choices :initarg :choices :initform (list "" "--") :reader select-choices) 109 | )) 110 | 111 | (defmethod input-attrs append ((field select-field)) 112 | (list* :id (get-field-id field) 113 | :name (field-name field) 114 | :disabled (input-disabled field) 115 | (input-extra field))) 116 | 117 | (defmethod render-field ((field select-field) &key value) 118 | (loop for (cval text) in (select-choices field) 119 | for opt-tag = `(:option :value ,cval ,@(when (equal cval value) (list :selected "t")) 120 | ,text) 121 | collect opt-tag into opts 122 | finally 123 | (return (write-tag `(:select ,@(get-input-attrs field) ,@opts))))) 124 | 125 | (defmethod to-lisp ((field select-field)) 126 | (unless (emptyp (field-str field)) (field-str field))) 127 | 128 | (defmethod validate-field ((field select-field) val) 129 | (when val 130 | (if (assoc val (select-choices field) :test #'equal) 131 | val 132 | (error 'field-error :message "Invalid choice")))) 133 | 134 | (defun make-choices (list val-maker txt-maker &key (optional t)) 135 | (let ((choices (loop for el in list 136 | collect (list (princ-to-string (funcall val-maker el)) 137 | (princ-to-string (funcall txt-maker el)))))) 138 | (if optional 139 | (cons (list "" "--") choices) 140 | choices))) 141 | 142 | (defclass form () 143 | ((fields :initarg :fields :initform nil :reader form-fields) 144 | (initials :initarg :init :initform nil :reader form-initials) 145 | (vars :initform nil :initarg :vars :accessor form-vars) 146 | (errors :initform nil :initarg :errors :reader form-errors) 147 | (data :initform nil :accessor form-data) 148 | (boundp :initform nil :accessor form-boundp) 149 | )) 150 | 151 | (defgeneric validate (form) 152 | (:documentation "validate form or raise field-error") 153 | (:method ((form form)) 154 | nil)) 155 | 156 | (defgeneric finalize (form) 157 | (:documentation "perform some action associated with form or raise field-error") 158 | (:method ((form form)) 159 | nil)) 160 | 161 | (defgeneric full-validate (form) 162 | (:documentation "Completely validate form and return errors if any")) 163 | 164 | (defmethod full-validate ((form form)) 165 | "Returns nil when no errors." 166 | ;; validate fields 167 | (loop for (keyword field) on (form-fields form) by #'cddr 168 | for field-validator = (field-validator field) 169 | for (value error-message) = (handler-case (list (validate-field field (to-lisp field))) 170 | (field-error (e) 171 | (with-slots (message) e 172 | (list nil message)))) 173 | if error-message 174 | append (list keyword error-message) into errors 175 | else 176 | append (list keyword value) into data 177 | finally 178 | (with-slots ((form-errors errors) (form-data data)) form 179 | (setf form-errors errors 180 | form-data data))) 181 | (when (form-errors form) 182 | (return-from full-validate (form-errors form))) 183 | ;;validate the whole form 184 | (handler-case 185 | (progn (validate form) (finalize form)) 186 | (field-error (e) 187 | (with-slots (field message) e 188 | (with-slots (errors) form 189 | (push message errors) 190 | (push field errors))))) 191 | (form-errors form)) 192 | 193 | (defmacro process-form (form on-error &body on-success) 194 | (let ((forms (if (listp form) form (list form))) 195 | (any-err (gensym "ERR"))) 196 | `(let ((,any-err nil)) 197 | ,@(loop for form in forms 198 | collect `(when (or (not (form-boundp ,form)) (full-validate ,form)) 199 | (setf ,any-err t))) 200 | (cond (,any-err ,on-error) 201 | (t ,@on-success))))) 202 | 203 | (defmacro def-form (class-name superclasses 204 | &body field-defs) 205 | `(progn 206 | (defclass ,class-name ,(or superclasses '(form)) 207 | ()) 208 | 209 | (defmethod initialize-instance :after ((form ,class-name) &key) 210 | ,@(loop 211 | for field-def in field-defs 212 | for (kw class . options) = field-def 213 | for initial = (getf options :initial :none) 214 | unless (eql initial :none) 215 | append (list kw initial) into initials 216 | append (list kw `(make-instance ',class ,@options :allow-other-keys t)) into fields 217 | finally 218 | (return 219 | `((setf (slot-value form 'initials) (append (slot-value form 'initials) 220 | (list ,@initials))) 221 | (setf (slot-value form 'fields) (append (slot-value form 'fields) 222 | (list ,@fields))))))))) 223 | 224 | (defun form-to-plist (form &aux all-fields (err-map (make-hash-table))) 225 | (loop for (field err) on (form-errors form) by #'cddr 226 | do (push (list :error err) (gethash field err-map))) 227 | (with-slots (initials boundp) form 228 | (list :fields 229 | (loop for (kw field) on (form-fields form) by #'cddr 230 | for fieldinfo = (list :label (render-label field) 231 | :field 232 | (render-field field 233 | :value (if (form-boundp form) 234 | (field-str field) 235 | (let ((val (getf initials kw :none))) 236 | (unless (eql val :none) 237 | (accept-value field val))))) 238 | :errors (nreverse (gethash kw err-map))) 239 | append (list kw fieldinfo) 240 | do (push fieldinfo all-fields)) 241 | :allfields (nreverse all-fields) 242 | :errors (nreverse (gethash nil err-map)) 243 | ))) 244 | 245 | (defun bind-form (form param-getter) 246 | "param-getter should be, or return, alist ((\"param_name\" . \"param_value\"))" 247 | (let ((params (if (listp param-getter) param-getter (funcall param-getter)))) 248 | (loop for (kw field) on (form-fields form) by #'cddr 249 | for name = (field-name field) 250 | for param = (and name (assoc name params :test #'equalp)) 251 | when param 252 | do (setf (slot-value field 'str-value) (cdr param)) 253 | ) 254 | (setf (slot-value form 'boundp) t))) 255 | 256 | (defun render-form (form &key (template *default-form-template*) env &allow-other-keys) 257 | (let* ((form-path (merge-pathnames template *form-template-directory*)) 258 | (emb:*escape-type* :raw) 259 | (emb:*case-sensitivity* nil)) 260 | (emb:execute-emb 261 | form-path 262 | :env (append (form-to-plist form) env)))) 263 | 264 | (defclass formset () 265 | ((forms :initform nil :reader formset-forms) 266 | (form-class :initarg :form :reader formset-form-class) 267 | (form-initargs :initarg :initargs :initform nil :reader formset-form-initargs) 268 | (errors :initform nil :reader form-errors) 269 | (boundp :initform nil :accessor form-boundp))) 270 | 271 | (defmethod initialize-instance :after ((formset formset) &key initial (extra 1)) 272 | (loop with forms 273 | for init in initial 274 | for form = (spawn-form formset :init init) 275 | do (push form forms) 276 | finally 277 | (when extra 278 | (loop repeat extra 279 | do (push (spawn-form formset) forms))) 280 | (setf (slot-value formset 'forms) (nreverse forms)))) 281 | 282 | (defun spawn-form (formset &rest args) 283 | (apply #'make-instance (formset-form-class formset) 284 | (append args (formset-form-initargs formset)))) 285 | 286 | (defmethod validate ((formset formset)) nil) 287 | 288 | (defmethod finalize ((formset formset)) nil) 289 | 290 | (defmethod full-validate ((formset formset)) 291 | (loop for form in (formset-forms formset) 292 | for errors = (and (form-boundp form) (full-validate form)) 293 | when errors 294 | collect errors into form-errors 295 | finally (when form-errors 296 | (return-from full-validate form-errors)) 297 | ) 298 | (handler-case 299 | (progn (validate formset) (finalize formset)) 300 | (field-error (e) 301 | (with-slots (field message) e 302 | (with-slots (errors) formset 303 | (push message errors) 304 | (push nil errors))))) 305 | (form-errors formset)) 306 | 307 | (defmethod form-data ((formset formset)) 308 | (loop for form in (formset-forms formset) 309 | when (form-boundp form) 310 | collect (form-data form))) 311 | 312 | (defun bind-formset (formset param-getter) 313 | (let ((params (if (listp param-getter) param-getter (funcall param-getter))) 314 | (prototype (spawn-form formset))) 315 | (multiple-value-bind (form-params n-forms) 316 | (loop for (kw field) on (form-fields prototype) by #'cddr 317 | for name = (string-right-trim "[]" (field-name field)) 318 | for param = (and name (assoc name params :test #'equalp)) 319 | when param 320 | collect (cons kw (cdr param)) into pparams 321 | and maximize (length (cdr param)) into mlen 322 | finally (return (values pparams mlen))) 323 | (loop with forms = (loop repeat n-forms collect (spawn-form formset)) 324 | for (kw . param) in form-params 325 | when param 326 | do (loop for form in forms 327 | for par in param 328 | for field = (getf (form-fields form) kw) 329 | do (setf (slot-value field 'str-value) par)) 330 | finally 331 | (loop for form in forms 332 | do (setf (slot-value form 'boundp) t)) 333 | (with-slots ((fforms forms) boundp) formset 334 | (setf fforms forms boundp t)))))) 335 | 336 | (defun render-formset (formset &rest rest &key default-args render-error-args render-default-args) 337 | (list 338 | :errors (if (form-errors formset) 339 | (let ((err-form (make-instance 'form :errors (form-errors formset)))) 340 | (apply #'render-form err-form (or render-error-args rest))) 341 | "") 342 | :forms (mapcar (lambda (form) (list :form (apply #'render-form form rest))) 343 | (formset-forms formset)) 344 | :default-form (apply #'render-form (apply #'spawn-form formset default-args) 345 | (or render-default-args rest)))) 346 | 347 | 348 | (defmacro def-formset (class-name form-class &optional superclasses) 349 | `(defclass ,class-name ,(or superclasses '(formset)) 350 | (,@(cond ((listp form-class) 351 | `((form-class :initform ',(car form-class)) 352 | (form-initargs :initform (list ,@(cdr form-class))))) 353 | (t `((form-class :initform ',form-class))))))) 354 | 355 | 356 | ;; validator utils 357 | 358 | (defun validator (validator &rest args) 359 | (lambda (val) (apply validator val args))) 360 | 361 | (defun validate-length (val start &optional end allow-empty) 362 | (let ((len (length val))) 363 | (when (and start (< len start) (or (not allow-empty) (> len 0))) 364 | (error 'field-error :message (format nil "Must be at least ~a characters long" start))) 365 | (when (and end (> len end)) 366 | (error 'field-error :message (format nil "Must be no longer than ~a characters" start))) 367 | ) 368 | val) 369 | 370 | (defun validate-regex (val regex &optional (fail-message "Incorrect format") free) 371 | (unless (ppcre:scan (if free regex (format nil "^~a$" regex)) val) 372 | (error 'field-error :message fail-message)) 373 | val) 374 | 375 | (defun validate-integer-str (val &key min max) 376 | (let ((num (handler-case (parse-integer val) 377 | (parse-error () (error 'field-error :message "Not a number"))))) 378 | (when (and min (< num min)) 379 | (error 'field-error :message (format nil "Must be at least ~a" min))) 380 | (when (and max (< max num)) 381 | (error 'field-error :message (format nil "Must be at most ~a" max))) 382 | num)) 383 | 384 | --------------------------------------------------------------------------------