[claw-cvs] r14 - in trunk/main/claw-core: . src tests

Author: achiumenti Date: Wed Mar 12 05:26:40 2008 New Revision: 14

Added: trunk/main/claw-core/src/validators.lisp Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/tests/test1.lisp Log: beginning of translators and i18n support

Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Wed Mar 12 05:26:40 2008 @@ -37,6 +37,7 @@ (:file "misc" :depends-on ("packages")) (:file "hunchentoot-overrides" :depends-on ("packages")) (:file "tags" :depends-on ("misc")) - (:file "components" :depends-on ("tags")) - (:file "lisplet" :depends-on ("components")) + (:file "validators" :depends-on ("tags")) + (:file "components" :depends-on ("tags" "validators")) + (:file "lisplet" :depends-on ("components")) (:file "server" :depends-on ("lisplet"))))))

Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Wed Mar 12 05:26:40 2008 @@ -52,10 +52,6 @@ (defmethod wcomponent-template((cform cform)) (let ((client-id (htcomponent-client-id cform)) (class (wcomponent-parameter-value cform :class))) - (when (null client-id) - (setf client-id "")) - (when (null class) - (setf class "")) (form> :static-id client-id :name client-id :class class @@ -111,6 +107,7 @@ :validator-handler nil :class nil :label nil + :translator *simple-translator* :validator nil :type :required))

@@ -118,26 +115,16 @@ '(:value :name))

(defmethod wcomponent-template ((cinput cinput)) - (let* ((client-id (htcomponent-client-id cinput)) + (let ((client-id (htcomponent-client-id cinput)) (type (wcomponent-parameter-value cinput :type)) - (visit-object (wcomponent-parameter-value cinput :visit-object)) - (accessor (wcomponent-parameter-value cinput :accessor)) - (reader (wcomponent-parameter-value cinput :reader)) - (class (wcomponent-parameter-value cinput :class)) - (value "") - (validation-errors (aux-request-value :validation-errors)) - (component-exceptions (assoc client-id validation-errors :test #'equal))) - (when (null visit-object) - (setf visit-object (htcomponent-page cinput))) - (when (null class) - (setf class "")) - (when component-exceptions - (if (string= class "") + (class (wcomponent-parameter-value cinput :class)) + (translator (wcomponent-parameter-value cinput :translator)) + (value "")) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) (setf class "error") (setf class (format nil "~a error" class)))) - (if (and (null reader) accessor) - (setf value (funcall (fdefinition accessor) visit-object)) - (setf value (funcall (fdefinition reader) visit-object))) + (setf value (translator-encode translator cinput)) (input> :static-id client-id :type type :name client-id @@ -145,22 +132,28 @@ :value value (wcomponent-informal-parameters cinput))))

-(defmethod wcomponent-after-rewind ((obj cinput) (pobj page)) - (let ((visit-object (wcomponent-parameter-value obj :visit-object)) - (accessor (wcomponent-parameter-value obj :accessor)) - (writer (wcomponent-parameter-value obj :writer)) - (validator (wcomponent-parameter-value obj :validator)) - (new-value (page-req-parameter pobj - (htcomponent-client-id obj) - (cinput-result-as-list obj)))) - (unless (null new-value) - (when (null visit-object) - (setf visit-object (htcomponent-page obj))) - (if (and (null writer) accessor) - (funcall (fdefinition `(setf ,accessor)) new-value visit-object) - (funcall (fdefinition writer) new-value visit-object)) - (when validator - (funcall validator))))) +(defmethod wcomponent-after-rewind ((cinput cinput) (page page)) + (let ((visit-object (wcomponent-parameter-value cinput :visit-object)) + (accessor (wcomponent-parameter-value cinput :accessor)) + (writer (wcomponent-parameter-value cinput :writer)) + (validator (wcomponent-parameter-value cinput :validator)) + (translator (wcomponent-parameter-value cinput :translator)) + (value)) + (multiple-value-bind (client-id request-value) + (component-id-and-value cinput) + (setf value + (handler-case + (translator-decode translator cinput) + (error () request-value))) + (unless (null value) + (when validator + (funcall validator value)) + (unless (component-validation-errors cinput) + (when (null visit-object) + (setf visit-object page)) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) value visit-object) + (funcall (fdefinition writer) value visit-object)))))))

;--------------------------------------------------------------------------------------- (defcomponent csubmit () () @@ -236,54 +229,5 @@ (htcomponent-body obj))))

-(defun component-id-and-value (component) - (let ((client-id (htcomponent-client-id component)) - (visit-object (wcomponent-parameter-value component :visit-object)) - (accessor (wcomponent-parameter-value component :accessor)) - (reader (wcomponent-parameter-value component :reader)) - (value "")) - (when (null visit-object) - (setf visit-object (htcomponent-page component))) - (if (and (null reader) accessor) - (setf value (funcall (fdefinition accessor) visit-object)) - (setf value (funcall (fdefinition reader) visit-object))) - (values client-id value))) - -(defun add-exception (id reason) - (let* ((validation-errors (aux-request-value :validation-errors)) - (component-exceptions (assoc id validation-errors :test #'equal))) - (if component-exceptions - (push reason (cdr component-exceptions)) - (push (cons id (list reason)) - (aux-request-value :validation-errors))))) - -(defun validator-required (component) - (multiple-value-bind (client-id value) - (component-id-and-value component) - (when (or (null value) (string= value "")) - (add-exception client-id - (format nil "Field ~a may not be null." (wcomponent-parameter-value component :label))))))

-;; ------------------------------------------------------------------------------------ -(defcomponent exce (cinput) () - (:default-initargs :result-as-list t) - (:documentation "This component renders as a normal SELECT tag class, -but it is request cycle aware."))

-(defmethod wcomponent-parameters :around ((obj cselect)) - (declare (ignore obj)) - (let ((params (call-next-method))) - (remf params :reader) - (remf params :type) - params)) - -(defmethod wcomponent-reserved-parameters ((obj cselect)) - (declare (ignore obj)) - '(:type :name)) - -(defmethod wcomponent-template ((obj cselect)) - (let ((client-id (htcomponent-client-id obj))) - (select> :static-id client-id - :name client-id - (wcomponent-informal-parameters obj) - (htcomponent-body obj)))) \ No newline at end of file

Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Wed Mar 12 05:26:40 2008 @@ -95,11 +95,7 @@ :error-code error-code))) (with-output-to-string (*standard-output*) (page-render error-page)))))))

-(defun lisplet-start-session () - "Starts a session boud to the current lisplet base path" - (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet))))) - -(defclass lisplet () +(defclass lisplet (i18n-aware) ((base-path :initarg :base-path :reader lisplet-base-path :documentation "common base path all resources registered into this lisplet") @@ -123,7 +119,7 @@ :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location") (redirect-protected-resources-p :initarg :redirect-protected-resources-p :accessor lisplet-redirect-protected-resources-p - :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) + :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) (:default-initargs :welcome-page nil :login-page nil :realm "claw" @@ -196,8 +192,10 @@ (uri (request-uri)) (welcome-page (lisplet-welcome-page lisplet))) (progn - (setf (aux-request-value 'lisplet) lisplet) - (setf (aux-request-value 'realm) (lisplet-realm lisplet)) + ;;(setf (aux-request-value 'lisplet) lisplet) + (setf (current-lisplet) lisplet) + ;;(setf (aux-request-value 'realm) (lisplet-realm lisplet)) + (setf (current-realm) (lisplet-realm lisplet)) (lisplet-check-authorization lisplet) (when (= (return-code) +http-ok+) (if (and welcome-page (string= uri base-path)) @@ -263,6 +261,6 @@ (format nil "Basic realm="~A"" (hunchentoot::quote-string (current-realm))))) (setf (return-code) +http-authorization-required+) (throw 'handler-done nil)) - (unless (user-in-role-p) + (unless (user-in-role-p allowed-roles) (setf (return-code) +http-forbidden+) (throw 'handler-done nil))))))))

Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Wed Mar 12 05:26:40 2008 @@ -29,6 +29,8 @@

(in-package :claw)

+(defvar *clawserver-base-path* nil) + (defvar *apache-http-port* 80 "Default apache http port when claw is running in mod_lisp mode") (defvar *apache-https-port* 443 @@ -71,25 +73,56 @@ (let ((result (remove-by-location (car location-cons) cons-list))) (setf result (push location-cons cons-list))))

+(defun lisplet-start-session () + "Starts a session boud to the current lisplet base path" + (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet))))) + + +(defun current-page (&optional (request *request*)) + "Returns the page that is rendering" + (aux-request-value 'page request)) + +(defun (setf current-page) (page &optional (request *request*)) + "Setf the page that is to be rendered" + (setf (aux-request-value 'page request) page)) + (defun current-realm (&optional (request *request*)) "Returns the realm under which the request has been sent" (aux-request-value 'realm request))

+(defun (setf current-realm) (realm &optional (request *request*)) + "Setf the realm under which the request has been sent" + (setf (aux-request-value 'realm request) realm)) + (defun current-lisplet (&optional (request *request*)) "Returns the lisplet instance from which the request comes from" (aux-request-value 'lisplet request))

+(defun (setf current-lisplet) (lisplet &optional (request *request*)) + "Sets the lisplet instance from which the request comes from" + (setf (aux-request-value 'lisplet request) lisplet)) + (defun current-server (&optional (request *request*)) "Returns the clawserver instance from which the request comes from" (aux-request-value 'clawserver request))

+(defun (setf current-server) (server &optional (request *request*)) + "Sets the clawserver instance from which the request comes from" + (setf (aux-request-value 'clawserver request) server)) + (defun current-principal (&optional (session *session*)) "Returns the principal(user) that logged into the application" (when session (session-value 'principal session)))

+(defun (setf current-principal) (principal &optional (session *session*)) + "Setf the principal(user) that logged into the application" + (unless session + (setf session (lisplet-start-session))) + (setf (session-value 'principal session) principal)) + (defun user-in-role-p (roles &optional (session *session*)) - "Detects if current principal belongs to any of the expressed roles" + "Detects if current principal belongs to any of the expressed roles" (let ((principal (current-principal session))) (when principal (loop for el in (principal-roles principal) thereis (member el roles))))) @@ -101,3 +134,53 @@ (defun login (&optional (request *request*)) "Perfoms a login action using the configuration object given for the request realm" (configuration-login (current-config request))) + +(defun flatten (tree &optional result-list) + "Traverses the tree in order, collecting even non-null leaves into a list." + (let ((result result-list)) + (loop for element in tree + do (cond + ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) + (t (push element result)))) + (nreverse result))) + +(defmacro message (key locale &optional (default "")) + (let ((current-lisplet (gensym)) + (current-page (gensym)) + (current-component (gensym)) + (result (gensym)) + (key-val key) + (locale-val locale) + (default-val default)) + `#'(lambda () + (let ((,current-lisplet (current-lisplet)) + (,current-page (current-page)) + (,current-component (current-component)) + (,result)) + (when ,current-lisplet + (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) + (when (and (null ,result) ,current-page) + (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when (and (null ,result) ,current-component) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) + (when (and (null ,result) (> (length ,locale-val) 2)) + (setf ,locale-val (subseq ,locale-val 0 2)) + (when ,current-lisplet + (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) + (when (and (null ,result) ,current-page) + (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when (and (null ,result) ,current-component) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))) + (when (null ,result) + (setf ,locale-val "") + (when ,current-lisplet + (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) + (when (and (null ,result) ,current-page) + (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when (and (null ,result) ,current-component) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))) + (if ,result + ,result + ,default-val))))) + + \ No newline at end of file

Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Wed Mar 12 05:26:40 2008 @@ -34,6 +34,7 @@

(defpackage :claw (:use :cl :hunchentoot :alexandria :cl-ppcre :cl-fad) + (:shadow :flatten) (:export :*html-4.01-strict* :*html-4.01-transitional* :*html-4.01-frameset* @@ -48,6 +49,7 @@ ;:request-realm :request-id-table-map ;:dyna-id + :flatten :tag-emptyp :tag-symbol-class :strings-to-jsarray @@ -55,6 +57,7 @@ :build-tagf :parse-htcomponent-function :page ;page classes hadle the whole rendering cycle + :message-dispatch :page-writer :page-can-print :page-url @@ -219,8 +222,7 @@ :csubmit :csubmit> :submit-link - :submit-link> - :validator-required + :submit-link> :lisplet :lisplet-realm :lisplet-pages @@ -268,5 +270,26 @@ :current-lisplet :current-server :current-realm + :current-page + :current-component + :page-current-component :user-in-role-p - :login)) + :login + :message + ;;validation + :translator + :translator-integer + :translator-encode + :translator-decode + :*simple-translator* + ;;:with-validators disabled + :validate + :validation-errors + :component-validation-errors + :validator-required + :validator-size + :validator-range + :validator-number + :validator-integer + :exception-monitor + :exception-monitor>))

Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Wed Mar 12 05:26:40 2008 @@ -398,7 +398,8 @@ (defmethod clawserver-dispatch-method ((clawserver clawserver)) (let ((result nil)) (progn - (setf (aux-request-value 'clawserver) clawserver) + ;(setf (aux-request-value 'clawserver) clawserver) + (setf (current-server) clawserver) (setf result (clawserver-dispatch-request clawserver)) (if (null result) #'(lambda () (when (= (return-code) +http-ok+) @@ -462,8 +463,8 @@ ;;;---------------------------------------------------------------------------- (defun login (&optional (request *request*)) "Perform user authentication for the reaml where the request has been created" - (let* ((server (aux-request-value 'clawserver)) - (realm (aux-request-value 'realm)) + (let* ((server (current-server request));(aux-request-value 'clawserver)) + (realm (current-realm request));(aux-request-value 'realm)) (login-config (gethash realm (clawserver-login-config server)))) (configuration-login login-config request)))

Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Wed Mar 12 05:26:40 2008 @@ -29,7 +29,8 @@

(in-package :claw)

- +(defgeneric message-dispatch (object key locale) + (:documentation "Returns the KEY translation by the given LOCALE"))

(defgeneric page-req-parameter (page name &optional as-list) (:documentation "This method returns a request parameter given by NAME searching first @@ -213,8 +214,6 @@ - WCOMPONENT is the tag instance - PAGE the page instance"))

-(defvar *clawserver-base-path* nil) - (defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" "Page doctype as HTML 4.01 STRICT")

@@ -262,22 +261,21 @@ (when (boundp '*request*) (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))))

- (defun parse-htcomponent-function (function-body) "This function parses attributes passed to a htcomponent creation function" (let ((attributes) (body)) - (loop for last-elem = nil then elem - for elem in function-body - do (if (or (and (stringp last-elem) (stringp elem)) - (and (null last-elem) (stringp elem)) - (subtypep (type-of elem) 'htcomponent) - (and (evenp (length attributes)) (stringp elem)) - body) - (push elem body) - (push elem attributes))) + (loop for last-elem = nil then elem + for elem in function-body + do (if (and (null body) + (or (keywordp elem) + (keywordp last-elem))) + (push elem attributes) + (when elem + (push elem body)))) (list (reverse attributes) (reverse body))))

+ (defun generate-id (id) "This function is very useful when having references to components id inside component body. When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute." @@ -325,8 +323,17 @@

;;;---------------------------------------------------------------- +(defclass message-dispatcher () + ()) + +(defclass i18n-aware (message-dispatcher) + ((message-dispatcher :initarg :message-dispatcher + :accessor message-dispatcher + :documentation "Reference to a MESSAGE-DISPATCHER instance")) + (:default-initargs :message-dispatcher nil) + (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE"))

-(defclass page() +(defclass page(i18n-aware) ((writer :initarg :writer :accessor page-writer :documentation "The output stream for this page instance") (lisplet :initarg :lisplet @@ -570,7 +577,8 @@ (let ((body (page-content page)) (jsonp (page-json-id-list page))) (if (null body) - (format nil "null body for page ~a~%" (type-of page)) + ;(format nil "null body for page ~a~%" (type-of page)) + (setf (current-page) page) (progn (page-init page) (when (page-req-parameter page *rewind-parameter*) @@ -587,9 +595,12 @@ (page-format-raw page "},classInjections:"") (setf (page-can-print page) t) (dolist (injection (page-init-injections page)) - (htcomponent-render injection page)) + (when injection + (htcomponent-render injection page))) (page-format-raw page "",instanceInjections:"") - (htcomponent-render (htbody-init-scripts-tag page) page) + (let ((init-scripts (htbody-init-scripts-tag page))) + (when init-scripts + (htcomponent-render init-scripts page))) (page-format-raw page ""}"))))))

(defmethod page-body-init-scripts ((page page)) @@ -639,6 +650,11 @@

(defmethod page-current-component ((page page)) (car (page-components-stack page))) + +(defmethod current-component () + (let ((page (current-page))) + (when page + (car (page-components-stack page))))) ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) (let* ((id (htcomponent-client-id htcomponent)) @@ -708,10 +724,12 @@ (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print htcomponent)) (htcomponent-json-print-start-component htcomponent)) - (dolist (tag body-list) - (if (stringp tag) - (htcomponent-render ($> tag) page) - (htcomponent-render tag page))) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (funcall child-tag)) + (t (htcomponent-render child-tag page))))) (when (null previous-print-status) (setf (page-can-print page) nil) (htcomponent-json-print-end-component htcomponent)))) @@ -722,7 +740,9 @@ (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn (assert (keywordp k)) - (when (and v (string-not-equal v "")) + (when (functionp v) + (setf v (funcall v))) + (when (and v (string-not-equal v "")) (page-format page " ~a="~a"" (string-downcase (if (eq k :static-id) "id" @@ -773,10 +793,12 @@ (htcomponent-json-print-start-component tag)) (when (or (page-can-print page) previous-print-status) (tag-render-starttag tag page)) - (dolist (tag body-list) - (if (stringp tag) - (htcomponent-render ($> tag) page) - (htcomponent-render tag page))) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (funcall child-tag)) + (t (htcomponent-render child-tag page))))) (when (or (page-can-print page) previous-print-status) (tag-render-endtag tag page)) (unless previous-print-status @@ -789,12 +811,15 @@ (let ((body-list (htcomponent-body hthead)) (injections (page-init-injections page))) (tag-render-starttag hthead page) - (dolist (tag body-list) - (if (stringp tag) - (htcomponent-render ($> tag) page) - (htcomponent-render tag page))) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (funcall child-tag)) + (t (htcomponent-render child-tag page))))) (dolist (injection injections) - (htcomponent-render injection page)) + (when injection + (htcomponent-render injection page))) (tag-render-endtag hthead page))))

;;;========= HTSTRING =================================== @@ -806,7 +831,9 @@ (let ((body (htcomponent-body htstring)) (jsonp (not (null (page-json-id-list page)))) (print-p (page-can-print page))) - (when (or print-p body) + (when (and print-p body) + (when (functionp body) + (setf body (funcall body))) (when jsonp (setf body (regex-replace-all """ (regex-replace-all "\\"" @@ -846,9 +873,11 @@ (unless (listp body) (setf body (list body))) (dolist (element body) - (if (stringp element) - (htcomponent-render ($raw> element) page) - (htcomponent-render element page))) + (when element + (cond + ((stringp element) (htcomponent-render ($> element) page)) + ((functionp element) (funcall element)) + (t (htcomponent-render element page))))) (if (null xml-p) (page-format page "~%//-->") (page-format page "~%//]]>"))) @@ -885,10 +914,12 @@ (htcomponent-json-print-start-component htbody)) (when (page-can-print page) (tag-render-starttag htbody page)) - (dolist (tag body-list) - (if (stringp tag) - (htcomponent-render ($> tag) page) - (htcomponent-render tag page))) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (funcall child-tag)) + (t (htcomponent-render child-tag page))))) (when (page-can-print page) (htcomponent-render (htbody-init-scripts-tag page) page) (tag-render-endtag htbody page)) @@ -903,7 +934,7 @@ js))

;;;========= WCOMPONENT =================================== -(defclass wcomponent (htcomponent) +(defclass wcomponent (htcomponent i18n-aware) ((parameters :initarg :parameters :accessor wcomponent-parameters :type cons @@ -1060,10 +1091,12 @@ (wcomponent-before-render wcomponent page) (unless (listp template) (setf template (list template))) - (dolist (tag template) - (if (stringp tag) - (htcomponent-render ($> tag) page) - (htcomponent-render tag page))) + (dolist (child-tag template) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (funcall child-tag)) + (t (htcomponent-render child-tag page))))) (wcomponent-after-render wcomponent page) (when (null previous-print-status) (setf (page-can-print page) nil) @@ -1071,3 +1104,37 @@

(defmethod wcomponent-before-render ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-render ((wcomponent wcomponent) (page page))) + +(defun component-id-and-value (component &key (from-request-p t) value-as-list-p) + (let ((client-id (htcomponent-client-id component)) + (page (htcomponent-page component)) + (visit-object (wcomponent-parameter-value component :visit-object)) + (accessor (wcomponent-parameter-value component :accessor)) + (reader (wcomponent-parameter-value component :reader)) + (result-as-list (cinput-result-as-list component)) + (value "")) + (when (null visit-object) + (setf visit-object (htcomponent-page component))) + (cond + (from-request-p (setf value (page-req-parameter page client-id value-as-list-p))) + ((and (null reader) accessor) (setf value (funcall (fdefinition accessor) visit-object))) + (t (setf value (funcall (fdefinition reader) visit-object)))) + (values client-id + (if result-as-list + (list value) + value)))) + + +(defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) + +(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) + (let ((dispatcher (message-dispatcher i18n-aware)) + (result)) + (when dispatcher + (progn + (setf result (message-dispatch dispatcher key locale)) + (when (null result)))) + + + +

Added: trunk/main/claw-core/src/validators.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/validators.lisp Wed Mar 12 05:26:40 2008 @@ -0,0 +1,273 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/components.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw) + +(defgeneric translator-encode (translator wcomponent) + (:documentation "Encodes the input component value, used when rendering the component")) + +(defgeneric translator-decode (translator wcomponent) + (:documentation "Decodes the input component value")) + +(defclass translator () + () + (:documentation "a translator object encodes and decodes values passed to a html input component")) + +(defmethod translator-encode ((translator translator) (wcomponent wcomponent)) + (let ((page (htcomponent-page wcomponent)) + (visit-object (wcomponent-parameter-value wcomponent :visit-object)) + (accessor (wcomponent-parameter-value wcomponent :accessor)) + (reader (wcomponent-parameter-value wcomponent :reader))) + (format nil "~a" (if (component-validation-errors wcomponent) + (page-req-parameter page (htcomponent-client-id wcomponent) nil) + (progn + (when (null visit-object) + (setf visit-object (htcomponent-page wcomponent))) + (if (and (null reader) accessor) + (funcall (fdefinition accessor) visit-object) + (funcall (fdefinition reader) visit-object))))))) + +(defmethod translator-decode ((translator translator) (wcomponent wcomponent)) + (multiple-value-bind (client-id new-value) + (component-id-and-value wcomponent) + new-value)) + +(defvar *simple-translator* (make-instance 'translator)) + +(defclass translator-integer (translator) + ((thousand-separator :initarg :thousand-separator + :reader translator-thousand-separator) + (always-show-signum :initarg :always-show-signum + :reader translator-always-show-signum)) + (:default-initargs :thousand-separator nil + :always-show-signum nil) + (:documentation "a translator object encodes and decodes integer values passed to a html input component")) + +(defmethod translator-encode ((translator translator-integer) (wcomponent wcomponent)) + (let* ((page (htcomponent-page wcomponent)) + (visit-object (wcomponent-parameter-value wcomponent :visit-object)) + (accessor (wcomponent-parameter-value wcomponent :accessor)) + (reader (wcomponent-parameter-value wcomponent :reader)) + (thousand-separator (translator-thousand-separator translator)) + (signum-directive (if (translator-always-show-signum translator) + "@" + "")) + (control-string (if thousand-separator + (format nil "~~3,' ,v:~aD" signum-directive) + (format nil "~~~ad" signum-directive))) + + (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) + (if (component-validation-errors wcomponent) + value + (progn + (when (null visit-object) + (setf visit-object (htcomponent-page wcomponent))) + (setf value (cond + ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) + (t (funcall (fdefinition reader) visit-object)))) + (if thousand-separator + (string-trim " " (format nil control-string thousand-separator value)) + (format nil control-string value)))))) + +(defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent)) + (let* ((thousand-separator (translator-thousand-separator translator))) + (multiple-value-bind (client-id new-value) + (component-id-and-value wcomponent) + (if thousand-separator + (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value "")) + (parse-integer new-value))))) + +;;========================================= +#| +(defclass translator-number (translator) + ((thousand-separator :initarg :thousand-separator + :reader translator-thousand-separator) + (decimals-separator :initarg :decimals-separator + :reader translator-decimals-separator) + (decimal-digits :initarg :decimal-digits + :reader translator-decimal-digits) + (always-show-signum :initarg :always-show-signum + :reader translator-always-show-signum)) + (:default-initargs :thousand-separator nil :decimals-separator #. + :integer-digits nil + :decimal-digits nil + :always-show-signum nil) + (:documentation "a translator object encodes and decodes integer values passed to a html input component")) + +(defmethod translator-encode ((translator translator-number) (wcomponent wcomponent)) + (let* ((page (htcomponent-page wcomponent)) + (visit-object (wcomponent-parameter-value wcomponent :visit-object)) + (accessor (wcomponent-parameter-value wcomponent :accessor)) + (reader (wcomponent-parameter-value wcomponent :reader)) + (thousand-separator (translator-thousand-separator translator)) + (decimal-digits (translator-decimal-digits translator)) + (decimals-separator (translator-decimals-separator translator)) + (signum-directive (if (translator-always-show-signum translator) + "@" + "")) + (integer-control-string (if thousand-separator + (format nil "~~3,' ,v:~aD" signum-directive) + (format nil "~~~ad" signum-directive))) + + (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) + (if (component-validation-errors wcomponent) + value + (progn + (when (null visit-object) + (setf visit-object (htcomponent-page wcomponent))) + (multiple-value-bind (int-value dec-value) + (floor (cond + ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) + (t (funcall (fdefinition reader) visit-object)))) + (format nil "~a~a" (if thousand-separator + (string-trim " " (format nil control-string thousand-separator int-value)) + (format nil control-string int-value)) + (cond + ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) + (format "~a~a" decimals-separator (make-string decimal-digits #\0))) + (decimal-digits + (format "~a~a" decimals-separator (make-string decimal-digits #\0)) + +(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent)) + (let* ((thousand-separator (translator-thousand-separator translator))) + (multiple-value-bind (client-id new-value) + (component-id-and-value wcomponent) + (if thousand-separator + (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value "")) + (parse-integer new-value))))) + +|# +;;---------------------------------------------------------------------------------------- +(defun add-exception (id reason) + (let* ((validation-errors (aux-request-value :validation-errors)) + (component-exceptions (assoc id validation-errors :test #'equal))) + (if component-exceptions + (setf (cdr component-exceptions) (append (cdr component-exceptions) (list reason))) + (if validation-errors + (setf (aux-request-value :validation-errors) (append validation-errors (list (cons id (list reason))))) + (setf (aux-request-value :validation-errors) (list (cons id (list reason)))))))) + + +(defun validate (test &key component message) + (let ((client-id (htcomponent-client-id component))) + (unless test + (add-exception client-id message)))) + +(defun validation-errors (&optional (request *request*)) + "Resurns possible validation errors occurred during form rewinding" + (aux-request-value :validation-errors request)) + +(defun component-validation-errors (component &optional (request *request*)) + "Resurns possible validation errors occurred during form rewinding bound to a specific component" + (let ((client-id (htcomponent-client-id component))) + (assoc client-id (validation-errors request) :test #'equal))) + +(defun validator-required (component value) + (when (stringp value) + (validate (and value (string-not-equal value "")) + :component component + :message (format nil "Field ~a may not be null." (wcomponent-parameter-value component :label))))) + +(defun validator-size (component value &key min-size max-size) + (let ((value-len 0)) + (when value + (setf value (format nil "~a" value)) + (setf value-len (length value)) + (or (= value-len 0) + (when min-size + (validate (>= value-len min-size) + :component component + :message (format nil "Size of ~a may not be less then ~a" + (wcomponent-parameter-value component :label) + min-size))) + (when max-size + (validate (<= value-len max-size) + :component component + :message (format nil "Size of ~a may not be more then ~a" + (wcomponent-parameter-value component :label) + max-size))))))) + +(defun validator-range (component value &key min max) + (when value + (or (when min + (validate (>= value min) + :component component + :message (format nil "Field ~a is not greater then or equal to ~d" (wcomponent-parameter-value component :label) min))) + (when max + (validate (<= value max) + :component component + :message (format nil "Field ~a is not less then or equal to ~d" (wcomponent-parameter-value component :label) max)))))) + +(defun validator-number (component value &key min max) + (when value + (let ((test (numberp value))) + (or (validate test + :component component + :message (format nil "Field ~a is not a valid number" (wcomponent-parameter-value component :label))) + (validator-range component value :min min :max max))))) + +(defun validator-integer (component value &key min max) + (when value + (let ((test (integerp value))) + (or (validate test + :component component + :message (format nil "Field ~a is not a valid integer" (wcomponent-parameter-value component :label))) + (validator-range component value :min min :max max))))) + + +;; ------------------------------------------------------------------------------------ +(defcomponent exception-monitor () () + (:documentation "If from submission contains exceptions. It displays exception messages")) + +(defmethod wcomponent-parameters ((exception-monitor exception-monitor)) + (declare (ignore exception-monitor)) + (list :class nil)) + +(defmethod wcomponent-template ((exception-monitor exception-monitor)) + (let ((client-id (htcomponent-client-id exception-monitor)) + (validation-errors (aux-request-value :validation-errors))) + (when validation-errors + (ul> :static-id client-id + (loop for component-exceptions in validation-errors + collect (loop for message in (cdr component-exceptions) + collect (li> message))))))) + +;;------------------------------------------------------------------------------------------- + +#| +(defmacro with-validators (&rest rest) + (let* ((component (gensym)) + (value (gensym)) + (validators (loop for validator in rest + collect (list 'funcall validator component value)))) + `#'(lambda (,value) + (let ((,component (current-component))) + (or ,@validators))))) +|# +

Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Wed Mar 12 05:26:40 2008 @@ -41,8 +41,6 @@ (defvar *test-lisplet2*) (setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2"))

- - ;;(defparameter *clawserver* (make-instance 'clawserver :port 4242))

(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 @@ -60,9 +58,10 @@ (when (and (string-equal user "kiuma") (string-equal password "password")) (progn - (unless session - (setf session (lisplet-start-session))) - (setf (session-value 'principal session) (make-instance 'principal :name user :roles '("user"))))))) + ;;(unless session + ;; (setf session (lisplet-start-session))) + ;;(setf (session-value 'principal session) (make-instance 'principal :name user :roles '("user"))))))) + (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))))

@@ -117,9 +116,11 @@ (defclass auth-page (page) ()) (defmethod page-content ((page auth-page)) (site-template> :title "Unauth test page" - (p> "not here"))) + (p> "protected content"))) (lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html") -(lisplet-protect *test-lisplet* "unauth.html" '("admin" "user")) +(lisplet-register-page-location *test-lisplet* 'auth-page "auth.html") +(lisplet-protect *test-lisplet* "auth.html" '("admin" "user")) +(lisplet-protect *test-lisplet* "unauth.html" '("nobody"))

(defclass index-page (page) ())

@@ -129,6 +130,8 @@ (ul> (li> (a> :href "login.html" "Do login")) + (li> (a> :href "info.html" + "Headers info")) (li> (a> :href "images/matrix.jpg" "show static file")) (li> (a> :href "images/matrix2.jpg" @@ -139,11 +142,28 @@ "realm on lisplet 'test2'")) (li> (a> :href "id-tests.html" "id generation test")) (li> (a> :href "form.html" "form components test")) + (li> (a> :href "auth.html" "authorized page")) (li> (a> :href "unauth.html" "unauthorized page")))))) +(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t) + +(defclass info-page (page) ()) + +(defmethod page-content ((o info-page)) + (let ((header-props (headers-in))) + (site-template> :title "Header info page" + (p> :id "p" + (table> + (tr> (td> :colspan "2" "Header info")) + (loop for key-val in header-props + collect (tr> + (td> (format nil "~a" (car key-val)) + (td> (format nil "~a" (cdr key-val))))))))))) + +(lisplet-register-page-location *test-lisplet* 'info-page "info.html") +

(defun test-image-file () (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) -(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t)

(lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg")

@@ -266,8 +286,10 @@ (surname :initarg :surname :accessor user-surname) (gender :initarg :gender - :accessor user-gender)) - (:default-initargs :name "" :surname "" :gender "")) + :accessor user-gender) + (age :initarg :age + :accessor user-age)) + (:default-initargs :name "" :surname "" :gender "" :age ""))

(defgeneric form-page-update-user (form-page))

@@ -282,21 +304,29 @@ :writer setf-gender :accessor form-page-gender) (user :initarg :user - :accessor form-page-user)) + :accessor form-page-user) + (age :initarg :age + :accessor form-page-age)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil :gender '("M") + :age 1800 :user (make-instance 'user)))

(defmethod form-page-update-user ((form-page form-page)) (let ((user (form-page-user form-page)) (name (form-page-name form-page)) (surname (form-page-surname form-page)) - (gender (first (form-page-gender form-page)))) + (gender (first (form-page-gender form-page))) + (age (form-page-age form-page))) (setf (user-name user) name (user-surname user) surname - (user-gender user) gender))) + (user-gender user) gender + (user-age user) age))) + +;(defmethod message-dispatch ((object form-page) key locale) +

(defmethod page-content ((o form-page)) (site-template> :title "a page title" @@ -308,17 +338,18 @@ (cinput> :id "name" :type "text" :label "Name" - :validator #'(lambda () - (validator-required (page-current-component o))) + :validator #'(lambda (value) + (validator-required (page-current-component o) value)) :accessor 'form-page-name)"*")) (tr> (td> "Surname") (td> (cinput> :id "surname" :type "text" - :label "Name" - :validator #'(lambda () - (validator-required (page-current-component o))) + :label "Surname" + :validator #'(lambda (value) + (validator-required (page-current-component o) value) + (validator-size (page-current-component o) value :min-size 1 :max-size 20)) :accessor 'form-page-surname)"*")) (tr> (td> "Gender") @@ -333,6 +364,18 @@ "Male" "Female")))))) (tr> + (td> "Age") + (td> + (cinput> :id "age" + :type "text" + :label "Age" + :translator (make-instance 'translator-integer :thousand-separator #') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validator-required component value) + (validator-integer component value :min 1 :max 2000))) + :accessor 'form-page-age)"*")) + (tr> (td> "Colors") (td> (cselect> :id "colors" @@ -350,12 +393,14 @@ (tr> (td> :colspan "2" (csubmit> :id "submit" :value "OK"))))) - (p> + (p> + (exception-monitor>) (hr>) (h2> "From result:") (div> (format nil "Name: ~a" (user-name (form-page-user o)))) (div> (format nil "Surname: ~a" (user-surname (form-page-user o)))) - (div> (format nil "Gender: ~a" (user-gender (form-page-user o))))))) + (div> (format nil "Gender: ~a" (user-gender (form-page-user o)))) + (div> (format nil "Age: ~a" (user-age (form-page-user o)))))))

(lisplet-register-page-location *test-lisplet* 'form-page "form.html")