| (defpackage :webutils.forms (:use :cl :araneida :split-sequence :html-encode :webutils.simple-serialized-classes :webutils.xml-mixed-mode) (:export :with-processed-form :form :form-field :textarea-form-field :hidden-form-field :immutable-form-field :selector-form-field :boolean-form-field :resubmit-form :form-html :define-form :define-template-form-field :define-class-gate-template-form-field :define-class-gate-form-field :keyword->pretty-string :pretty-string->keyword :nonempty-string-validator :password-form-field :submit-ecase :fail-check :define-form-field :define-form-field-length-constraint :form-get-url :call-parent-method :get-error-message :define-optional-template :set-slots-from-form-values :multiple-form-block)) (defpackage :webutils.form-cookies (:use)) (in-package :webutils.forms) (webutils::export-all :webutils.forms) (defun protect-for-dom (string) (substitute #\_ #\- string)) (defvar *failed-acceptor-form-catch-tag* (gensym)) (defmacro fail-check (reason &rest offending) `(throw *failed-acceptor-form-catch-tag* (values nil ,reason ',offending))) (defun translate-length-constraint-into-words (constraint value field &key invert) (ecase (first constraint) ((< > <= >= =) (format nil "The length of the ~(~A~) should ~A ~A ~A." field (if invert "not be" "be") (case (first constraint) (< "less than") (> "greater than") (<= "less than or equal to") (>= "greater than or equal to") (= "equal to")) (second constraint))) (and (if invert (translate-length-constraint-into-words `(or ,@(mapcar (lambda (constraint) `(not ,constraint)) (cdr constraint))) value field :invert nil) (translate-length-constraint-into-words (find-failing-constraint constraint value) value field))) (or (if invert (translate-length-constraint-into-words `(and ,@(mapcar (lambda (constraint) `(not ,constraint)) (cdr constraint))) value field :invert nil) (format nil "None of the following were true: ~{~A~^ ~}" (mapcar (lambda (constraint) (translate-length-constraint-into-words constraint value field :invert invert)) (cdr constraint))))) (not (translate-length-constraint-into-words (second constraint) value field :invert (not invert))))) (defun find-failing-constraint (constraint-expr value) (case (first constraint-expr) (and (some (lambda (constraint) (find-failing-constraint constraint value)) (cdr constraint-expr))) (or (unless (not (every (lambda (constraint) (find-failing-constraint constraint value)) (cdr constraint-expr))) constraint-expr)) (not (unless (find-failing-constraint (second constraint-expr) value) constraint-expr)) (t (unless (funcall (first constraint-expr) value (second constraint-expr)) constraint-expr)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun translate-length-constraint (constraint var) (labels ((malformed () (error "The constraint ~S is malformed." constraint))) (ecase (first constraint) ((< > <= >= =) (unless (and (eql (length constraint) 2) (numberp (second constraint))) (malformed)) `(,(first constraint) ,var ,(second constraint))) (not (unless (eql (length constraint) 2) (malformed)) `(not ,(translate-length-constraint (second constraint) var))) ((and or) `(,(first constraint) ,@(mapcar (lambda (constraint) (translate-length-constraint constraint var)) (cdr constraint)))))))) (defun translate-max-constraint (constraint) (case (first constraint) (< (1- (second constraint))) ((<= =) (second constraint)))) (defvar *forms* nil) (defvar *template-form-fields* nil) (defmacro define-template-form-field (template-name class &body arguments) (setf *template-form-fields* (remove template-name *template-form-fields* :key #'car)) (let ((found (find class *template-form-fields* :key #'first))) (if found (push (list* template-name (second found) (append (loop for (key lambda) on arguments by #'cddr with argument = (gensym) collect key collect `(flet ((call-parent-method (,argument) (funcall ,(getf (cddr found) key '#'identity) ,argument))) ,lambda)) (loop for (key lambda) on (cddr found) by #'cddr unless (getf arguments key) collect key unless (getf arguments key) collect lambda))) *template-form-fields*) (push (list* template-name class arguments) *template-form-fields*))) (values)) (defmacro define-optional-template (template-name class) `(define-template-form-field ,template-name ,class :string-acceptor (lambda (string) (if (zerop (length string)) nil (call-parent-method string))) :string-to-value-translator (lambda (string) (if (zerop (length string)) nil (call-parent-method string))) :value-to-string-translator (lambda (string) (if string (call-parent-method string) "")))) (defmacro define-class-gate-template-form-field (template-name form-field-class class &key (key-slot-type 'string)) `(define-template-form-field ,template-name ,form-field-class ,@(gate-initargs form-field-class class key-slot-type))) (define-condition form-generation-error (serious-condition) ((reason :initform "Unknown" :accessor form-generation-error-reason :initarg :reason))) (defclass form () ((name :initarg :name :accessor form-name) (fields :initform nil :initarg :fields :accessor form-fields) (semantic-checks :initform nil :initarg :semantic-checks :accessor form-semantic-checks) (inherit-forms :initform nil :initarg :inherit-forms :accessor form-inherit-forms) (expected-fields :initform nil :initarg :expected-fields :accessor form-expected-fields) (submit-text-mappings :initform nil :initarg :submit-text-mappings :accessor form-submit-text-mappings) (cookie :initform (gentemp "COOKIE" (find-package :webutils.form-cookies)) :initarg :cookie :accessor form-cookie))) (defmethod print-object ((object form) stream) (print-unreadable-object (object stream :type t :identity t) (princ (form-name object) stream))) (defun find-form (form-name) (find form-name *forms* :key #'form-name)) (defun (setf find-form) (new-value form-name) (car (setf *forms* (cons new-value (remove form-name *forms* :key #'form-name))))) (defun situation-intersect (situation1 situation2) (or (find t situation2) (find t situation1) (intersection situation1 situation2))) (defun specifier-active (designator1 designator2) (and (eq (car designator1) (car designator2)) (situation-intersect (cdr designator1) (cdr designator2)))) (defun find-form-field (form-name specifier) (labels ((%find (form) (let ((found (find specifier (form-fields form) :key (lambda (field) (cons (form-field-name field) (form-field-situations field))) :test #'specifier-active))) (or found (loop for (form . situations) in (form-inherit-forms form) for val = nil if (and (situation-intersect (cdr specifier) situations) (setf val (%find (find-form form)))) do (return val)))))) (%find (or (find-form form-name) (error "No such form ~A" form-name))))) (defun (setf find-form-field) (new-value form-name specifier) (let ((form (or (find-form form-name) (error "No such form ~A" form-name)))) (labels ((%find (form) (let ((found (find specifier (form-expected-fields form) :test #'specifier-active))) (or found (loop for (form . situations) in (form-inherit-forms form) for val = nil if (and (situation-intersect (cdr specifier) situations) (setf val (%find (find-form form)))) do (return val)))))) (unless (%find form) (error "The field ~A is not expected in the form ~A." specifier form-name))) (car (setf (form-fields form) (cons new-value (remove specifier (form-fields form) :key (lambda (field) (cons (form-field-name field) (form-field-situations field))) :test #'equal)))))) (defmacro form-field (form-name &rest specifier) `(find-form-field ',form-name ',specifier)) (defun situation-specificity (sit1 sit2) (reduce #'+ (mapcar (lambda (situation) (count situation sit2)) sit1))) (defun union-form-fields (fields) (remove-duplicates fields :key #'form-field-name :from-end t)) (defun union-form-field-situations/names (fields) (remove-duplicates fields :key #'car :from-end t)) (defun active-form-fields (form situations) (union-form-fields (nconc (loop for field in (form-fields form) if (or (find t (form-field-situations field)) (situation-intersect (form-field-situations field) situations)) collect field) (loop for (inherit . inherit-situations) in (form-inherit-forms form) if (situation-intersect inherit-situations situations) nconc (active-form-fields (find-form inherit) situations))))) (defun active-form-field-situations/names (form situations) (union-form-field-situations/names (nconc (loop for field in (form-expected-fields form) if (or (find t (cdr field)) (situation-intersect (cdr field) situations)) collect field) (loop for (inherit . inherit-situations) in (form-inherit-forms form) if (situation-intersect situations inherit-situations) nconc (active-form-field-situations/names (find-form inherit) situations))))) (defun active-form-field-names (form situations) (mapcar #'car (active-form-field-situations/names form situations))) (defun active-form-fields-in-correct-order (form situations) (let ((active-field-names (active-form-field-names form situations)) (active-fields (active-form-fields form situations))) (mapcar (lambda (name) (find name active-fields :key #'form-field-name)) active-field-names))) (defun active-form-semantic-checks (form situations) (nconc (loop for (inherit . inherit-situations) in (form-inherit-forms form) if (situation-intersect situations inherit-situations) append (active-form-semantic-checks (find-form inherit) situations)) (loop for check in (form-semantic-checks form) if (or (null (car check)) (situation-intersect (car check) situations)) collect check))) (defun active-form-semantic-checks/variables (form situations) (nconc (loop for (inherit . inherit-situations) in (form-inherit-forms form) if (situation-intersect situations inherit-situations) append (active-form-semantic-checks/variables (find-form inherit) situations)) (loop for check in (form-semantic-checks form) if (or (null (car check)) (situation-intersect (car check) situations)) collect (cons (active-form-field-names form (car check)) check)))) (defun make-semantic-check-lambda-form (variables semantic-check-body) (let ((block-name (gensym)) (reason (gensym)) (offending (gensym))) `(macrolet ((fail-check (,reason &rest ,offending) `(return-from ,',block-name (values nil ,,reason ',,offending)))) (lambda (,@variables) (declare (ignorable ,@variables)) (block ,block-name ,@semantic-check-body t))))) (defmacro define-form (form-name (&rest inherit-forms) (&rest expected-fields) &body options) (flet ((%fix (thing) (if (symbolp thing) (list thing t) thing))) (let ((semantic-checks (remove :semantic-check options :key #'car :test-not #'eq)) (submit-text-mappings (remove :submit-text options :key #'car :test-not #'eq)) (cookie (gentemp "COOKIE" (find-package :webutils.form-cookies))) (inherit-forms (mapcar #'%fix inherit-forms)) (expected-fields (mapcar #'%fix expected-fields))) (mapc (lambda (form-name-and-situation) (unless (find-form (car form-name-and-situation)) (error "Inherited form ~A has not yet been defined." (car form-name-and-situation)))) inherit-forms) (setf (find-form form-name) (make-instance 'form :name form-name :inherit-forms inherit-forms :expected-fields expected-fields :cookie cookie)) `(setf (find-form ',form-name) (make-instance 'form :name ',form-name :fields nil :expected-fields ',expected-fields :inherit-forms ',inherit-forms :submit-text-mappings (list ,@(mapcar (lambda (submit-text) `(cons ',(butlast (cdr submit-text)) ,(car (last submit-text)))) submit-text-mappings)) :semantic-checks (list ,@(loop for check-option in semantic-checks appending (multiple-value-bind (situations body) (loop for (possible-situation . rest) on (cdr check-option) while (keywordp possible-situation) collect possible-situation into situations finally (return (values situations (cons possible-situation rest)))) (let ((situations (or situations '(t)))) (loop for situation in situations collect `(cons ',(list situation) ,(make-semantic-check-lambda-form (active-form-field-names (find-form form-name) (list situation)) body))))))) :cookie ',cookie))))) (defmacro define-form-field ((form-name name &rest situations) class &body arguments) (let ((template (assoc class *template-form-fields*)) (situations (or situations '(t)))) (when (and template arguments) (warn "Warning: template form field ~A found; arguments will be ignored." class)) (if template `(setf (form-field ,form-name ,name ,@situations) (make-instance ',(second template) :name ',name :situations ',situations ,@(cddr template))) `(setf (form-field ,form-name ,name ,@situations) (make-instance ',class :name ',name :situations ',situations ,@arguments))))) (defmacro define-form-field-length-constraint ((form-name name &rest situations) &body constraint-body) (let ((g (make-symbol "VALUE")) (p (make-symbol "PRETTY-NAME")) (constraint (if (eql (length constraint-body) 1) (first constraint-body) `(and ,@constraint-body)))) `(setf (form-field-length-constraint (form-field ,form-name ,name ,@situations)) (lambda (,g ,p) (unless ,(translate-length-constraint constraint g) (fail-check (translate-length-constraint-into-words ',constraint ,g ,p)))) (form-field-max-length (form-field ,form-name ,name ,@situations)) ,(translate-max-constraint constraint)))) (defmacro define-class-gate-form-field ((form-name name &rest situations) form-field-class class &key (key-slot-type 'string)) `(define-form-field (,form-name ,name ,@situations) ,form-field-class ,@(gate-initargs form-field-class class key-slot-type))) (defun keyword->pretty-string (keyword) (let ((split (split-sequence #\- (symbol-name keyword)))) (when (and (> (length split) 1) (equal (first (last split)) "P")) (setf split (nconc (butlast split 2) (list (concatenate 'string (first (last split 2)) "?"))))) (format nil "~@(~{~A~^ ~}~)" split))) (defun pretty-string->keyword (string) (intern (format nil "~:@(~{~A~^-~}~)" (split-sequence #\space string)) :keyword)) (defgeneric form-field-in-table-p (field)) (defgeneric form-field-accepting-html (field initial-value)) (defgeneric gate-initargs (form-class class-name key-type)) (defclass form-field () ((name :initarg :name :accessor form-field-name) (situations :initarg :situations :accessor form-field-situations) (pretty-name :initarg :pretty-name :accessor form-field-pretty-name) (string-acceptor :initarg :string-acceptor :accessor form-field-string-acceptor :initform (constantly t)) (string-to-value-translator :initarg :string-to-value-translator :accessor form-field-string-to-value-translator :initform #'identity) (value-to-string-translator :initarg :value-to-string-translator :accessor form-field-value-to-string-translator :initform #'identity) (default-value :initarg :default-value :accessor form-field-default-value :initform nil) (length-constraint :initarg :length-cons |