- claw-cvs@common-lisp.net - mailman3.common-lisp.net

[claw-cvs] r15 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 12 Mar '08

12 Mar '08

Author: achiumenti Date: Wed Mar 12 07:49:10 2008 New Revision: 15 Modified: trunk/main/claw-core/src/tags.lisp Log: implemented message-dispatch for I18N-AWARE class 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 07:49:10 2008 @@ -1133,7 +1133,9 @@ (when dispatcher (progn (setf result (message-dispatch dispatcher key locale)) - (when (null result)))) + (when (and (null result) (> (length key) 2)) + (setf result (message-dispatch dispatcher (subseq key 0 2) locale))))) + result))

1 0

[claw-cvs] r14 - in trunk/main/claw-core: . src tests
by achiumenti＠common-lisp.net 12 Mar '08

12 Mar '08

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")

1 0

[claw-cvs] r13 - in trunk/main/claw-core: src tests
by achiumenti＠common-lisp.net 19 Feb '08

19 Feb '08

Author: achiumenti Date: Tue Feb 19 06:24:12 2008 New Revision: 13 Modified: trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/tests/test1.lisp Log: added beginning of validation support. added method page-current-component to page Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Tue Feb 19 06:24:12 2008 @@ -40,33 +40,41 @@ (:documentation "This component render as a FORM tag class, but it is aware of the request cycle and is able to fire an action on rewind")) -(defmethod cform-rewinding-p ((obj cform) (pobj page)) - (string= (htcomponent-client-id obj) - (page-req-parameter pobj *rewind-parameter*))) - -(defmethod wcomponent-parameters ((o cform)) - (list :id :required :action nil)) - -(defmethod wcomponent-template((o cform)) - (let ((client-id (htcomponent-client-id o))) +(defmethod cform-rewinding-p ((cform cform) (page page)) + (string= (htcomponent-client-id cform) + (page-req-parameter page *rewind-parameter*))) + +(defmethod wcomponent-parameters ((cform cform)) + (list :id :required + :class nil + :action nil)) + +(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 - (wcomponent-informal-parameters o) + :class class + (wcomponent-informal-parameters cform) (input> :name *rewind-parameter* :type "hidden" :value client-id) - (htcomponent-body o)))) + (htcomponent-body cform)))) (defmethod wcomponent-before-rewind ((obj cform) (pobj page)) (setf (page-current-form pobj) obj)) (defmethod wcomponent-after-rewind ((obj cform) (pobj page)) - (let ((action (wcomponent-parameter-value obj :action))) - (unless (or (null action) (null (cform-rewinding-p obj pobj))) - (funcall (fdefinition action) pobj)) - (setf (page-current-form pobj) nil))) + (let ((validation-errors (aux-request-value :validation-errors)) + (action (wcomponent-parameter-value obj :action))) + (unless validation-errors + (when (or action (cform-rewinding-p obj pobj)) + (funcall (fdefinition action) pobj)) + (setf (page-current-form pobj) nil)))) ;-------------------------------------------------------------------------------- @@ -94,34 +102,54 @@ (:default-initargs :result-as-list nil) (:documentation "Request cycle aware component the renders as an INPUT tag class")) -(defmethod wcomponent-parameters ((o cinput)) - (list :id :required :reader nil :writer nil :visit-object nil :accessor nil :type :required)) +(defmethod wcomponent-parameters ((cinput cinput)) + (list :id :required + :reader nil + :writer nil + :visit-object nil + :accessor nil + :validator-handler nil + :class nil + :label nil + :validator nil + :type :required)) -(defmethod wcomponent-reserved-parameters ((o cinput)) +(defmethod wcomponent-reserved-parameters ((cinput cinput)) '(:value :name)) -(defmethod wcomponent-template ((obj cinput)) - (let ((client-id (htcomponent-client-id obj)) - (type (wcomponent-parameter-value obj :type)) - (visit-object (wcomponent-parameter-value obj :visit-object)) - (accessor (wcomponent-parameter-value obj :accessor)) - (reader (wcomponent-parameter-value obj :reader)) - (value "")) +(defmethod wcomponent-template ((cinput 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 obj))) + (setf visit-object (htcomponent-page cinput))) + (when (null class) + (setf class "")) + (when component-exceptions + (if (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))) (input> :static-id client-id :type type :name client-id + :class class :value value - (wcomponent-informal-parameters obj)))) + (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)) + (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)))) @@ -130,7 +158,9 @@ (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))))) + (funcall (fdefinition writer) new-value visit-object)) + (when validator + (funcall validator))))) ;--------------------------------------------------------------------------------------- (defcomponent csubmit () () @@ -205,3 +235,55 @@ (wcomponent-informal-parameters obj) (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/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Tue Feb 19 06:24:12 2008 @@ -100,4 +100,4 @@ (defun login (&optional (request *request*)) "Perfoms a login action using the configuration object given for the request realm" - (configuration-login (current-config request))) \ No newline at end of file + (configuration-login (current-config request))) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Tue Feb 19 06:24:12 2008 @@ -71,6 +71,7 @@ :page-indent :page-xmloutput :page-doc-type + :page-current-component :htclass-body :htcomponent :htcomponent-page @@ -219,6 +220,7 @@ :csubmit> :submit-link :submit-link> + :validator-required :lisplet :lisplet-realm :lisplet-pages Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Tue Feb 19 06:24:12 2008 @@ -109,6 +109,9 @@ See PAGE-BODY-INIT-SCRIPTS form more info. - PAGE is the page instance that must be given")) +(defgeneric page-current-component (page) + (:documentation "The component being processed into one of the rendering phases")) + (defgeneric htcomponent-rewind (htcomponent page) (:documentation "This internal method is the first called during the request cycle phase. It is evaluated when a form action or an action-link action is fired. It is used to update all visit objects slots. @@ -353,6 +356,9 @@ (json-component-count :initarg :json-component-count :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") (request-parameters :initarg :request-parameters) + (components-stack :initform nil + :accessor page-components-stack + :documentation "A stack of components enetered into rendering process.") (url :initarg :url :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t @@ -631,6 +637,8 @@ tag-list)) +(defmethod page-current-component ((page page)) + (car (page-components-stack page))) ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) (let* ((id (htcomponent-client-id htcomponent)) @@ -659,13 +667,25 @@ (page-format-raw page "\"")))) (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page)) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))) (defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page)) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))) (defmethod htcomponent-render :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page)) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))) + +(defmethod htcomponent-rewind :after ((htcomponent htcomponent) (page page)) + (pop (page-components-stack page))) + +(defmethod htcomponent-prerender :after ((htcomponent htcomponent) (page page)) + (pop (page-components-stack page))) + +(defmethod htcomponent-render :after ((htcomponent htcomponent) (page page)) + (pop (page-components-stack page))) (defmethod htcomponent-rewind ((htcomponent htcomponent) (page page)) (dolist (tag (htcomponent-body htcomponent)) @@ -702,7 +722,7 @@ (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn (assert (keywordp k)) - (when v + (when (and v (string-not-equal v "")) (page-format page " ~a=\"~a\"" (string-downcase (if (eq k :static-id) "id" @@ -890,16 +910,20 @@ :documentation "must be a plist or nil") (reserved-parameters :initarg :reserved-parameters :accessor wcomponent-reserved-parameters - :type cons :documentation "Parameters that may not be used in the constructor function") + :type cons + :documentation "Parameters that may not be used in the constructor function") (informal-parameters :initarg :informal-parameters :accessor wcomponent-informal-parameters - :type cons :documentation "Informal parameters are parameters optional for the component") + :type cons + :documentation "Informal parameters are parameters optional for the component") (allow-informal-parameters :initarg :allow-informal-parameters :reader wcomponent-allow-informal-parametersp - :allocation :class :documentation "Determines if the component accepts informal parameters") + :allocation :class + :documentation "Determines if the component accepts informal parameters") (template :initform nil :accessor wcomponent-template - :type htcomponent :documentation "The component template. What gives to each wcomponent its unique aspect and features")) + :type htcomponent + :documentation "The component template. What gives to each wcomponent its unique aspect and features")) (:default-initargs :informal-parameters nil :reserved-parameters nil :parameters nil Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Tue Feb 19 06:24:12 2008 @@ -99,7 +99,12 @@ (html> (head> (title> - (wcomponent-parameter-value o ':title))) + (wcomponent-parameter-value o ':title)) + (style> :type "text/css" +"input.error { + background-color: #FF9999; +} +")) (body> (wcomponent-informal-parameters o) (div> @@ -113,7 +118,6 @@ (defmethod page-content ((page auth-page)) (site-template> :title "Unauth test page" (p> "not here"))) -; (claw-require-authorization)) (lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html") (lisplet-protect *test-lisplet* "unauth.html" '("admin" "user")) @@ -233,7 +237,7 @@ (td> "Username") (td> (cinput> :id "username" - :type "text" + :type "text" :accessor 'login-page-username))) (tr> (td> "Password") @@ -256,38 +260,66 @@ (lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) -(defclass form-page (page) +(defclass user () + ((name :initarg :name + :accessor user-name) + (surname :initarg :surname + :accessor user-surname) + (gender :initarg :gender + :accessor user-gender)) + (:default-initargs :name "" :surname "" :gender "")) + +(defgeneric form-page-update-user (form-page)) + +(defclass form-page (page user) ((name :initarg :name :accessor form-page-name) (surname :initarg :surname :accessor form-page-surname) - (gender :initarg :gender - :reader form-page-gender - :writer setf-gender) (colors :initarg :colors - :accessor form-page-colors)) - + :accessor form-page-colors) + (gender :initarg :gender + :writer setf-gender + :accessor form-page-gender) + (user :initarg :user + :accessor form-page-user)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil - :gender '("M"))) + :gender '("M") + :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)))) + (setf (user-name user) name + (user-surname user) surname + (user-gender user) gender))) (defmethod page-content ((o form-page)) (site-template> :title "a page title" - (cform> :id "testform" :method "post" + (cform> :id "testform" :method "post" :action 'form-page-update-user (table> (tr> (td> "Name") (td> (cinput> :id "name" :type "text" - :accessor 'form-page-name))) + :label "Name" + :validator #'(lambda () + (validator-required (page-current-component o))) + :accessor 'form-page-name)"*")) (tr> (td> "Surname") (td> (cinput> :id "surname" :type "text" - :accessor 'form-page-surname))) + :label "Name" + :validator #'(lambda () + (validator-required (page-current-component o))) + :accessor 'form-page-surname)"*")) (tr> (td> "Gender") (td> @@ -318,9 +350,12 @@ (tr> (td> :colspan "2" (csubmit> :id "submit" :value "OK"))))) - (div> (format nil "Name: ~a" (form-page-name o))) - (div> (format nil "Surname: ~a" (form-page-surname o))) - (div> (format nil "Gender: ~a" (first (form-page-gender o)))))) + (p> + (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))))))) (lisplet-register-page-location *test-lisplet* 'form-page "form.html")

1 0

[claw-cvs] r12 - trunk/main/claw-core/tests
by achiumenti＠common-lisp.net 17 Feb '08

17 Feb '08

Author: achiumenti Date: Sun Feb 17 14:43:03 2008 New Revision: 12 Modified: trunk/main/claw-core/tests/test1.lisp Log: test for realm page corrected Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Sun Feb 17 14:43:03 2008 @@ -46,7 +46,7 @@ ;;(defparameter *clawserver* (make-instance 'clawserver :port 4242)) (defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 - :mod-lisp-p t + :mod-lisp-p nil :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) @@ -159,29 +159,28 @@ (defclass realm-page (page) ()) (defmethod page-content ((o realm-page)) - (let ((lisplet (page-lisplet o))) - (when (or (null *session*) (not (string= (session-realm *session*) (lisplet-realm lisplet)))) - (progn - (lisplet-start-session) - (setf (session-value 'RND-NUMBER) (random 1000)))) - (site-template> :title "Realm test page" - (p> - "session" - (ul> - (li> (a> :href "http://www.gentoo.org" :target "gentoo" - "gentoo")) - (li> (a> :href "../test/realm.html" :target "clwo1" - "realm on lisplet 'test'")) - (li> (a> :href "../test2/realm.html" :target "clwo2" + (when (null *session*) + (lisplet-start-session)) + (unless (session-value 'RND-NUMBER) + (setf (session-value 'RND-NUMBER) (random 1000))) + (site-template> :title "Realm test page" + (p> + "session" + (ul> + (li> (a> :href "http://www.gentoo.org" :target "gentoo" + "gentoo")) + (li> (a> :href "../test/realm.html" :target "clwo1" + "realm on lisplet 'test'")) + (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) - (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) - (li> "Remote Addr: " (session-remote-addr *session*)) - (li> "User agent: " (session-user-agent *session*)) - (li> "Lisplet Realm: " (lisplet-realm (page-lisplet o))) - (li> "Session Realm: " (session-realm *session*)) - (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) - (li> "Request Realm: " (hunchentoot::realm *request*))))))) - + (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) + (li> "Remote Addr: " (session-remote-addr *session*)) + (li> "User agent: " (session-user-agent *session*)) + (li> "Lisplet Realm: " (lisplet-realm (page-lisplet o))) + (li> "Session Realm: " (session-realm *session*)) + (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) + (li> "Request Realm: " (hunchentoot::realm *request*)))))) + (lisplet-register-page-location *test-lisplet* 'realm-page "realm.html") (lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html")

1 0

[claw-cvs] r11 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 17 Feb '08

17 Feb '08

Author: achiumenti Date: Sun Feb 17 14:39:00 2008 New Revision: 11 Modified: trunk/main/claw-core/src/lisplet.lisp Log: corrected error hanling Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Sun Feb 17 14:39:00 2008 @@ -86,7 +86,7 @@ (setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) - (let* ((error-handlers (current-lisplet)) + (let* ((error-handlers (lisplet-error-hadlers (current-lisplet))) (handler (gethash error-code error-handlers))) (if handler (funcall handler)

1 0

[claw-cvs] r10 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 16 Feb '08

16 Feb '08

Author: achiumenti Date: Sat Feb 16 10:01:13 2008 New Revision: 10 Modified: trunk/main/claw-core/src/server.lisp Log: added some documentation Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Sat Feb 16 10:01:13 2008 @@ -29,55 +29,98 @@ (in-package :claw) -(defgeneric clawserver-register-lisplet (obj lisplet-obj) +(defgeneric clawserver-register-lisplet (clawserver lisplet) (:documentation "This method registers a lisplet for request dispatching -- OBJ the CLAWSERVER instance -- LISPLET-OBJ the LISPLET instance")) +- CLAWSERVER the CLAWSERVER instance +- LISPLET the LISPLET instance")) -(defgeneric clawserver-unregister-lisplet (obj lisplet-obj) +(defgeneric clawserver-unregister-lisplet (clawserver lisplet) (:documentation "This method unregisters a lisplet from request dispatching -- OBJ the CLAWSERVER instance -- LISPLET-OBJ the LISPLET instance")) +- CLAWSERVER the CLAWSERVER instance +- LISPLET the LISPLET instance")) -(defgeneric clawserver-dispatch-request (obj)) ;internal -(defgeneric clawserver-dispatch-method (obj)) ;internal +(defgeneric clawserver-dispatch-request (clawserver) + (:documentation "Dispatches http requests through registered lisplets")) -(defgeneric clawserver-start (obj) +(defgeneric clawserver-dispatch-method (clawserver) + (:documentation "Uses CLAWSERVER-DISPATCH-REQUEST to perform dispatching")) + +(defgeneric clawserver-start (clawserver) (:documentation "Starts the server")) -(defgeneric clawserver-stop (obj) + +(defgeneric clawserver-stop (clawserver) (:documentation "Stops the server")) -(defgeneric (setf clawserver-port) (val obj)) -(defgeneric (setf clawserver-sslport) (val obj)) -(defgeneric (setf clawserver-address) (val obj)) -(defgeneric (setf clawserver-name) (val obj)) -(defgeneric (setf clawserver-sslname) (val obj)) -(defgeneric (setf clawserver-mod-lisp-p) (val obj)) -(defgeneric (setf clawserver-use-apache-log-p) (val obj)) -(defgeneric (setf clawserver-input-chunking-p) (val obj)) -(defgeneric (setf clawserver-read-timeout) (val obj)) -(defgeneric (setf clawserver-write-timeout) (val obj)) -#+(and :unix (not :win32)) (defgeneric (setf clawserver-setuid) (val obj)) -#+(and :unix (not :win32)) (defgeneric (setf clawserver-setgid) (val obj)) -#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-certificate-file) (val obj)) -#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-file) (val obj)) -#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-password) (val obj)) -(defgeneric clawserver-register-configuration(clawserver realm configuration)) +(defgeneric (setf clawserver-port) (port clawserver) + (:documentation "Sets the claw server http port. When server is started an error will be signaled.")) + +(defgeneric (setf clawserver-sslport) (sslport clawserver) + (:documentation "Sets the claw server https port. When server is started an error will be signaled.")) + +(defgeneric (setf clawserver-address) (address clawserver) + (:documentation "Binds the claw server to a specific address. When server is started an error will be signaled.")) + +(defgeneric (setf clawserver-name) (name clawserver) + (:documentation "Sets the name of the server that dispatches http requests.")) + +(defgeneric (setf clawserver-sslname) (sslname clawserver) + (:documentation "Sets the name of the server that dispatches https requests.")) + +(defgeneric (setf clawserver-mod-lisp-p) (mod-lisp-p clawserver) + (:documentation "When not null binds the claw server to apache using mod_lisp2. When server is started an error will be signaled.")) + +(defgeneric (setf clawserver-use-apache-log-p) (apache-log-p clawserver) + (:documentation "When boud to apache with mod_lisp2 if not nil, uses apache logging. When server is started an error will be signaled.")) + +(defgeneric (setf clawserver-input-chunking-p) (input-chunking-p clawserver) + (:documentation "Sets input-chunking-p, when true the server will accept request +bodies without a Content-Length header if the client uses chunked transfer encoding. +If you want to use this feature behind mod_lisp, you should make sure that your combination of +Apache and mod_lisp can cope with that. When server is started an error will be signaled.")) -(defgeneric configuration-login (configuration &optional request)) +(defgeneric (setf clawserver-read-timeout) (read-timeout clawserver) + (:documentation "Sets the read timeout in seconds. When server is started an error will be signaled.")) -(define-condition http-forbidden-error (error) ()) -(define-condition http-authorization-required-error (error) ()) +(defgeneric (setf clawserver-write-timeout) (write-timeout clawserver) + (:documentation "Sets the write timeout in seconds. When server is started an error will be signaled.")) + +#+(and :unix (not :win32)) (defgeneric (setf clawserver-setuid) (setuid clawserver) + (:documentation "Sets the uid under which the server runs (Only for *NIX). When server is started an error will be signaled.")) + +#+(and :unix (not :win32)) (defgeneric (setf clawserver-setgid) (setgid clawserver) + (:documentation "Sets the gid under which the server runs (Only for *NIX). When server is started an error will be signaled.")) + +#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-certificate-file) (certificate-file clawserver) + (:documentation "The ssl certificate file for https connections. When server is started an error will be signaled.")) + +#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-file) (ssl-privatekey-file clawserver) + (:documentation "The ssl private key file for https connections. When server is started an error will be signaled.")) + +#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-password) (ssl-privatekey-password clawserver) + (:documentation "The password for the ssl private key file. When server is started an error will be signaled.")) + +(defgeneric clawserver-register-configuration(clawserver realm configuration) + (:documentation "Registers a configuration object for the given realm into the server. The configuration +will perform the authentication logic.")) + +(defgeneric configuration-login (configuration &optional request) + (:documentation "Authenticate a user creating a principal object that will be stored into the http session. +If no session is present one will be created, if the authentication succeds the principal instance is returned")) (defclass error-page (page) ((title :initarg :title - :reader page-title) + :reader page-title + :documentation "The page title") (error-code :initarg :error-code - :reader page-error-code)) - (:documentation "This is the template page class used to render + :reader page-error-code + :documentation "The error code to display")) + (:documentation "This is the page class used to render the http error messages.")) -(defcomponent error-page-template () ()) +(defcomponent error-page-template () + () + (:documentation "The template for the error-page")) + (defmethod wcomponent-parameters ((error-page-template error-page-template)) (list :title :required :error-code :required :style " @@ -138,46 +181,67 @@ (defclass clawserver () ((port :initarg :port - :reader clawserver-port) + :reader clawserver-port + :documentation "Returns the claw server http port") (sslport :initarg :sslport - :reader clawserver-sslport) + :reader clawserver-sslport + :documentation "Returns the claw server https port") (address :initarg :address - :reader clawserver-address) + :reader clawserver-address + :documentation "Returns the address where claw server is bound to.") (name :initarg :name - :reader clawserver-name) + :reader clawserver-name + :documentation "Returns the name of the server that dispatches http requests.") (sslname :initarg :sslname - :reader clawserver-sslname) + :reader clawserver-sslname + :documentation "Returns the name of the server that dispatches https requests.") (mod-lisp-p :initarg :mod-lisp-p - :reader clawserver-mod-lisp-p) + :reader clawserver-mod-lisp-p + :documentation "Returns not nil when the server is bound to apache through mod_lisp") (use-apache-log-p :initarg :use-apache-log-p - :reader clawserver-use-apache-log-p) + :reader clawserver-use-apache-log-p + :documentation "Returns not nil when the server uses apache logging") (input-chunking-p :initarg :input-chunking-p - :reader clawserver-input-chunking-p) + :reader clawserver-input-chunking-p + :documentation "When true the server will accept request +bodies without a Content-Length header if the client uses chunked transfer encoding. +If you want to use this feature behind mod_lisp, you should make sure that your combination of +Apache and mod_lisp can cope with that.") (read-timeout :initarg :read-timeout - :reader clawserver-read-timeout) + :reader clawserver-read-timeout + :documentation "Returns the server read timeout in seconds.") (write-timeout :initarg :write-timeout - :reader clawserver-write-timeout) + :reader clawserver-write-timeout + :documentation "Returns the server write timeout in seconds.") (login-config :initform (make-hash-table :test 'equal) :accessor clawserver-login-config :documentation "An hash table holding a pair of realm, -expressed as string, and a predicate. The predicate should take two arguments (login and password), and return non-nil if the login call +expressed as string, and a predicate. The predicate should take two arguments (login and password), and return a principal instance if the login call succeeds.") #+(and :unix (not :win32)) (setuid :initarg :setuid - :reader clawserver-setuid) + :reader clawserver-setuid + :documentation "Returns the uid under which the server runs.") #+(and :unix (not :win32)) (setgid :initarg :setgid - :reader clawserver-setgid) + :reader clawserver-setgid + :documentation "Returns the gid under which the server runs.") #-:hunchentoot-no-ssl (ssl-certificate-file :initarg :ssl-certificate-file - :reader clawserver-ssl-certificate-file) + :reader clawserver-ssl-certificate-file + :documentation "The ssl certificate file for https connections.") #-:hunchentoot-no-ssl (ssl-privatekey-file :initarg :ssl-privatekey-file - :reader clawserver-ssl-privatekey-file) + :reader clawserver-ssl-privatekey-file + :documentation "The ssl private key file for https connections") #-:hunchentoot-no-ssl (ssl-privatekey-password :initarg :ssl-privatekey-password - :reader clawserver-ssl-privatekey-password) + :reader clawserver-ssl-privatekey-password + :documentation "The password for the ssl private key file for https connections") (server :initform nil - :accessor clawserver-server) + :accessor clawserver-server + :documentation "The hunchentoot server dispatching http requests.") (sslserver :initform nil - :accessor clawserver-sslserver) + :accessor clawserver-sslserver + :documentation "The hunchentoot server dispatching https requests.") (lisplets :initform nil - :accessor clawserver-lisplets)) + :accessor clawserver-lisplets + :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is a dispatcher for that lisplet")) (:default-initargs :address nil :name (gensym) :sslname (gensym) @@ -212,33 +276,33 @@ (:default-initargs :roles nil) (:documentation "An instance of PRINCIPAL is stored into session after a user successfully login into the application.")) -(defmethod initialize-instance :after ((obj clawserver) &rest keys) +(defmethod initialize-instance :after ((clawserver clawserver) &rest keys) (let ((use-apache-log-p (getf keys :use-apache-log-p :undefined)) #-:hunchentoot-no-ssl (ssl-privatekey-file (getf keys :ssl-privatekey-file :undefined))) (when (eq use-apache-log-p :undefined) - (setf (clawserver-use-apache-log-p obj) (getf keys :mod-lisp-p))) + (setf (clawserver-use-apache-log-p clawserver) (getf keys :mod-lisp-p))) #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined) - (setf (clawserver-ssl-privatekey-file obj) (getf keys :ssl-certificate-file))))) + (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) -(defmethod clawserver-register-lisplet ((obj clawserver) (lisplet-obj lisplet)) - (let ((lisplets (clawserver-lisplets obj)) +(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) + (let ((lisplets (clawserver-lisplets clawserver)) (server-base-path *clawserver-base-path*) - (location (lisplet-base-path lisplet-obj))) + (location (lisplet-base-path lisplet))) (unless (null server-base-path) (setf location (format nil "~@[~a~]~a" server-base-path location))) - (setf (clawserver-lisplets obj) (sort-dispatchers (push-location-cons + (setf (clawserver-lisplets clawserver) (sort-dispatchers (push-location-cons (cons location (create-prefix-dispatcher location #'(lambda () - (lisplet-dispatch-method lisplet-obj)) - (lisplet-realm lisplet-obj))) + (lisplet-dispatch-method lisplet)) + (lisplet-realm lisplet))) lisplets))))) -(defmethod clawserver-unregister-lisplet ((obj clawserver) (lisplet-obj lisplet)) - (let ((lisplets (clawserver-lisplets obj)) +(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) + (let ((lisplets (clawserver-lisplets clawserver)) (server-base-path *clawserver-base-path*) - (location (lisplet-base-path lisplet-obj))) + (location (lisplet-base-path lisplet))) (unless (null server-base-path) (setf location (format nil "~@[~a~]~a" server-base-path location))) (remove-by-location location lisplets))) @@ -246,122 +310,122 @@ ;;;-------------------------- WRITERS ---------------------------------------- -(defmethod (setf clawserver-port) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-port) (port (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change port when server is started")) - (setf (slot-value obj 'port) val)) + (setf (slot-value clawserver 'port) port)) -(defmethod (setf clawserver-sslport) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-sslport) (sslport (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change SSL port when server is started")) - (setf (slot-value obj 'sslport) val)) + (setf (slot-value clawserver 'sslport) sslport)) -(defmethod (setf clawserver-address) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-address) (address (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change binding address when server is started")) - (setf (slot-value obj 'address) val)) + (setf (slot-value clawserver 'address) address)) -(defmethod (setf clawserver-name) (val (obj clawserver)) - (unless (null (clawserver-server obj)) - (setf (server-name (clawserver-server obj)) val)) - (setf (slot-value obj 'name) val)) - -(defmethod (setf clawserver-sslname) (val (obj clawserver)) - (unless (null (clawserver-sslserver obj)) - (setf (server-name (clawserver-sslserver obj)) val)) - (setf (slot-value obj 'sslname) val)) +(defmethod (setf clawserver-name) (name (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) + (setf (server-name (clawserver-server clawserver)) name)) + (setf (slot-value clawserver 'name) name)) + +(defmethod (setf clawserver-sslname) (sslname (clawserver clawserver)) + (unless (null (clawserver-sslserver clawserver)) + (setf (server-name (clawserver-sslserver clawserver)) sslname)) + (setf (slot-value clawserver 'sslname) sslname)) -(defmethod (setf clawserver-mod-lisp-p) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-mod-lisp-p) (mod-lisp-p (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change mod-lisp property when server is started")) - (setf (slot-value obj 'mod-lisp-p) val)) + (setf (slot-value clawserver 'mod-lisp-p) mod-lisp-p)) -(defmethod (setf clawserver-use-apache-log-p) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-use-apache-log-p) (use-apache-log-p (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change logging property when server is started")) - (setf (slot-value obj 'use-apache-log-p) val)) + (setf (slot-value clawserver 'use-apache-log-p) use-apache-log-p)) -(defmethod (setf clawserver-input-chunking-p) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-input-chunking-p) (input-chunking-p (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change chunking property when server is started")) - (setf (slot-value obj 'input-chunking-p) val)) + (setf (slot-value clawserver 'input-chunking-p) input-chunking-p)) -(defmethod (setf clawserver-read-timeout) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-read-timeout) (read-timeout (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change read timeout property when server is started")) - (setf (slot-value obj 'read-timeout) val)) + (setf (slot-value clawserver 'read-timeout) read-timeout)) -(defmethod (setf clawserver-write-timeout) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +(defmethod (setf clawserver-write-timeout) (write-timeout (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change write timeout property when server is started")) - (setf (slot-value obj 'write-timeout) val)) + (setf (slot-value clawserver 'write-timeout) write-timeout)) -#+(and :unix (not :win32)) (defmethod (setf clawserver-setuid) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +#+(and :unix (not :win32)) (defmethod (setf clawserver-setuid) (setuid (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change uid property when server is started")) - (setf (slot-value obj 'setuid) val)) + (setf (slot-value clawserver 'setuid) setuid)) -#+(and :unix (not :win32)) (defmethod (setf clawserver-setgid) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +#+(and :unix (not :win32)) (defmethod (setf clawserver-setgid) (setgid (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change gid property when server is started")) - (setf (slot-value obj 'setgid) val)) + (setf (slot-value clawserver 'setgid) setgid)) -#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-certificate-file) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-certificate-file) (ssl-certificate-file (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change ssl certificate file property when server is started")) - (setf (slot-value obj 'ssl-certificate-file) val)) + (setf (slot-value clawserver 'ssl-certificate-file) ssl-certificate-file)) -#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-file) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-file) (ssl-privatekey-file (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change ssl privatekey file property when server is started")) - (setf (slot-value obj 'ssl-privatekey-file) val)) + (setf (slot-value clawserver 'ssl-privatekey-file) ssl-privatekey-file)) -#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-password) (val (obj clawserver)) - (unless (null (clawserver-server obj)) +#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-password) (ssl-privatekey-password (clawserver clawserver)) + (unless (null (clawserver-server clawserver)) (error "Cannot change ssl privatekey password property when server is started")) - (setf (slot-value obj 'ssl-privatekey-password) val)) + (setf (slot-value clawserver 'ssl-privatekey-password) ssl-privatekey-password)) ;;;-------------------------- METHODS ---------------------------------------- (defmethod clawserver-register-configuration ((clawserver clawserver) realm (configuration configuration)) (setf (gethash realm (clawserver-login-config clawserver)) configuration)) -(defmethod clawserver-dispatch-request ((obj clawserver)) - (let ((lisplets (clawserver-lisplets obj))) +(defmethod clawserver-dispatch-request ((clawserver clawserver)) + (let ((lisplets (clawserver-lisplets clawserver))) (loop for dispatcher in lisplets for action = (funcall (cdr dispatcher) *request*) when action return (funcall action)))) -(defmethod clawserver-dispatch-method ((obj clawserver)) +(defmethod clawserver-dispatch-method ((clawserver clawserver)) (let ((result nil)) (progn - (setf (aux-request-value 'clawserver) obj) - (setf result (clawserver-dispatch-request obj)) + (setf (aux-request-value 'clawserver) clawserver) + (setf result (clawserver-dispatch-request clawserver)) (if (null result) #'(lambda () (when (= (return-code) +http-ok+) (setf (return-code *reply*) +http-not-found+))) #'(lambda () result))))) -(defmethod clawserver-start ((obj clawserver)) - (let ((port (clawserver-port obj)) - (sslport (clawserver-sslport obj)) - (address (clawserver-address obj)) +(defmethod clawserver-start ((clawserver clawserver)) + (let ((port (clawserver-port clawserver)) + (sslport (clawserver-sslport clawserver)) + (address (clawserver-address clawserver)) (dispatch-table (list #'(lambda (request) (declare (ignorable request)) - (clawserver-dispatch-method obj)))) - (name (clawserver-name obj)) - (sslname (clawserver-sslname obj)) - (mod-lisp-p (clawserver-mod-lisp-p obj)) - (use-apache-log-p (clawserver-use-apache-log-p obj)) - (input-chunking-p (clawserver-input-chunking-p obj)) - (read-timeout (clawserver-read-timeout obj)) - (write-timeout (clawserver-write-timeout obj)) - (uid (clawserver-setuid obj)) - (gid (clawserver-setgid obj)) - (ssl-certificate-file (clawserver-ssl-certificate-file obj)) - (ssl-privatekey-file (clawserver-ssl-privatekey-file obj)) - (ssl-privatekey-password (clawserver-ssl-privatekey-password obj))) + (clawserver-dispatch-method clawserver)))) + (name (clawserver-name clawserver)) + (sslname (clawserver-sslname clawserver)) + (mod-lisp-p (clawserver-mod-lisp-p clawserver)) + (use-apache-log-p (clawserver-use-apache-log-p clawserver)) + (input-chunking-p (clawserver-input-chunking-p clawserver)) + (read-timeout (clawserver-read-timeout clawserver)) + (write-timeout (clawserver-write-timeout clawserver)) + (uid (clawserver-setuid clawserver)) + (gid (clawserver-setgid clawserver)) + (ssl-certificate-file (clawserver-ssl-certificate-file clawserver)) + (ssl-privatekey-file (clawserver-ssl-privatekey-file clawserver)) + (ssl-privatekey-password (clawserver-ssl-privatekey-password clawserver))) (progn - (setf (clawserver-server obj) + (setf (clawserver-server clawserver) (start-server :port port :address address :dispatch-table dispatch-table @@ -374,7 +438,7 @@ #+(and :unix (not :win32)) :setuid uid #+(and :unix (not :win32)) :setgid gid)) #-:hunchentoot-no-ssl (when ssl-certificate-file - (setf (clawserver-sslserver obj) + (setf (clawserver-sslserver clawserver) (start-server :port sslport :address address :dispatch-table dispatch-table @@ -390,20 +454,21 @@ :ssl-privatekey-file ssl-privatekey-file :ssl-privatekey-password ssl-privatekey-password)))))) -(defmethod clawserver-stop ((obj clawserver)) +(defmethod clawserver-stop ((clawserver clawserver)) (progn - (setf (clawserver-server obj) (stop-server (clawserver-server obj))) - (when (clawserver-sslserver obj) - (setf (clawserver-sslserver obj) (stop-server (clawserver-sslserver obj)))))) + (setf (clawserver-server clawserver) (stop-server (clawserver-server clawserver))) + (when (clawserver-sslserver clawserver) + (setf (clawserver-sslserver clawserver) (stop-server (clawserver-sslserver clawserver)))))) ;;;---------------------------------------------------------------------------- (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)) (login-config (gethash realm (clawserver-login-config server)))) (configuration-login login-config request))) -(defun start-clawserver (clawserver-obj +(defun start-clawserver (clawserver &key (port 80) address (name (gensym)) @@ -421,7 +486,7 @@ :address address :dispatch-table (list #'(lambda (request) (declare (ignorable request)) - (clawserver-dispatch-method clawserver-obj))) + (clawserver-dispatch-method clawserver))) :name name :mod-lisp-p mod-lisp-p :use-apache-log-p use-apache-log-p @@ -434,29 +499,3 @@ #-:hunchentoot-no-ssl :ssl-privatekey-file ssl-privatekey-file #-:hunchentoot-no-ssl :ssl-privatekey-password ssl-privatekey-password)) -#| - (defun claw-require-authorization (&optional (request *request*)) - "Sends back appropriate headers to require basic HTTP authentication -\(see RFC 2617) for the realm REALM." - ;(log-message :info "REALM:::::: ~a" (current-realm)) - (setf (header-out "WWW-Authenticate") - (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm))) - (return-code *reply*) - +http-authorization-required+) - (throw 'handler-done nil)) -|# - -#| - (defun claw-require-authorization (&optional (request *request*)) - "Sends back appropriate headers to require basic HTTP authentication -\(see RFC 2617) for the realm REALM." - ;(log-message :info "REALM:::::: ~a" (current-realm)) - (when (eq (lisplet-authentication-type lisplet) :basic) - (setf (header-out "WWW-Authenticate") - (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm))) -; (setf (return-code *reply*) -; +http-authorization-required+) - (cond - ((null (principal)) (setf (return-code) +http-authorization-required+)) - (t (setf (return-code) +http-forbidden+)))) -|# \ No newline at end of file

1 0

[claw-cvs] r9 - in trunk/main/claw-core: src tests
by achiumenti＠common-lisp.net 15 Feb '08

15 Feb '08

Author: achiumenti Date: Fri Feb 15 10:12:46 2008 New Revision: 9 Modified: 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/tests/test1.lisp Log: added some documentation added lisplet error hanlders logic Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Fri Feb 15 10:12:46 2008 @@ -29,47 +29,110 @@ (in-package :claw) -;(print *this-file*) - -(defgeneric lisplet-register-function-location (obj function location &key welcome-pagep login-pagep)) -(defgeneric lisplet-register-page-location (obj page-class location &key welcome-pagep login-pagep)) - -(defgeneric lisplet-register-resource-location (obj uri url &optional content-type)) - -(defgeneric lisplet-dispatch-request (obj)) -(defgeneric lisplet-dispatch-method (obj)) -(defgeneric lisplet-protect (lisplet location roles)) -(defgeneric lisplet-check-authorization (lisplet &optional request)) -(defgeneric lisplet-authentication-type (lisplet)) +(defgeneric lisplet-register-function-location (lisplet function location &key welcome-page-p login-page-p) + (:documentation "Registers a function into a lisplet for dispatching. +parameters: +- LISPLET the lisplet that will dispatch the function +- FUNCTION the function to register for dispatching +- LOCATION The url location where the function will be registered (relative to the lisplet base path) +keys: +- :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location +- :LOGIN-PAGE-P Marks the function as a login page")) + +(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p) + (:documentation "Registers a page into a lisplet for dispatching. +parameters: +- LISPLET the lisplet that will dispatch the page +- PAGE-CLASS symbol name of the page that is to be registerd for dispatching +- LOCATION The url location where the page will be registered (relative to the lisplet base path) +keys: +- :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location +- :LOGIN-PAGE-P Marks the page as a login page")) + +(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type) + (:documentation "Registers a resource (file or directory) into a lisplet for dispatching. +parameters: +- LISPLET the lisplet that will dispatch the page +- RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching +- LOCATION The url location where the resource will be registered (relative to the lisplet base path) +- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type")) + +(defgeneric lisplet-dispatch-method (lisplet) + (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST +- LISPLET the lisplet object")) + +(defgeneric lisplet-dispatch-request (lisplet) + (:documentation "Dispatches the http request. +- LISPLET the lisplet object")) + +(defgeneric lisplet-protect (lisplet location roles) + (:documentation "protects all the resources that start with the given LOCATION, making them available only if the +user is logged and belongs at least to one of the given roles. +parameters: +- LISPLET the lisplet object. +- LOCATION the location that must be protected. +- ROLES a string list containing all the roles allowed to acces the given location.")) + +(defgeneric lisplet-check-authorization (lisplet &optional request) + (:documentation "Performs authentication and authorization checking. +Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the +lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login.")) + +(defgeneric lisplet-authentication-type (lisplet) + (:documentation "When there is no page or function registered into the lisplet as login page returns :BASIC, otherwise returns :FORM. +parameters: +- LISPLET the lisplet object.")) (setf *http-error-handler* + ;;overrides the default hunchentoot error handling #'(lambda (error-code) - (let ((error-page (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) - :error-code error-code))) - (with-output-to-string (*standard-output*) (page-render error-page))))) + (let* ((error-handlers (current-lisplet)) + (handler (gethash error-code error-handlers))) + (if handler + (funcall handler) + (let ((error-page (make-instance 'error-page + :title (format nil "Server error: ~a" error-code) + :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 () ((base-path :initarg :base-path - :reader lisplet-base-path) + :reader lisplet-base-path + :documentation "common base path all resources registered into this lisplet") (welcome-page :initarg :welcome-page - :accessor lisplet-welcome-page) + :accessor lisplet-welcome-page + :documentation "url location for the welcome page") (login-page :initarg :login-page - :accessor lisplet-login-page) + :accessor lisplet-login-page + :documentation "url location for the welcome page") (realm :initarg :realm - :reader lisplet-realm) + :reader lisplet-realm + :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") (pages :initform nil - :accessor lisplet-pages) + :accessor lisplet-pages + :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher") + (error-handlers :initform (make-hash-table) + :accessor lisplet-error-hadlers + :documentation "An hash table where keys are http error codes and values are functions with no parameters") (protected-resources :initform nil - :accessor lisplet-protected-resources) + :accessor lisplet-protected-resources + :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)) + :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")) (:default-initargs :welcome-page nil :login-page nil :realm "claw" - :redirect-protected-resources-p nil)) + :redirect-protected-resources-p nil) + (:documentation "A lisplet is a container for resources provided trhough the clawserver. +It is similar, for purposes, to a JAVA servlet")) (defun build-lisplet-location (lisplet location) + "Constructs a full path prepending the lisplet base path to the given location" (let ((server-base-path *clawserver-base-path*) (base-path (lisplet-base-path lisplet))) (if location @@ -84,36 +147,36 @@ :form :basic)) -(defmethod lisplet-register-function-location ((obj lisplet) function location &key welcome-pagep login-pagep) - (let ((pages (lisplet-pages obj)) - (new-location (build-lisplet-location obj location))) - (setf (lisplet-pages obj) +(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) + (let ((pages (lisplet-pages lisplet)) + (new-location (build-lisplet-location lisplet location))) + (setf (lisplet-pages lisplet) (sort-dispatchers (push-location-cons (cons new-location (create-prefix-dispatcher new-location function - (lisplet-realm obj))) + (lisplet-realm lisplet))) pages))) - (when welcome-pagep - (setf (lisplet-welcome-page obj) new-location)) - (when login-pagep - (setf (lisplet-login-page obj) new-location)))) - -(defmethod lisplet-register-page-location ((obj lisplet) page-class location &key welcome-pagep login-pagep) - (let ((new-location (build-lisplet-location obj location))) - (lisplet-register-function-location obj + (when welcome-page-p + (setf (lisplet-welcome-page lisplet) new-location)) + (when login-page-p + (setf (lisplet-login-page lisplet) new-location)))) + +(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p) + (let ((new-location (build-lisplet-location lisplet location))) + (lisplet-register-function-location lisplet #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet obj :url new-location)))) + (page-render (make-instance page-class :lisplet lisplet :url new-location)))) location - :welcome-pagep welcome-pagep - :login-pagep login-pagep))) + :welcome-page-p welcome-page-p + :login-page-p login-page-p))) -(defmethod lisplet-register-resource-location ((obj lisplet) resource-path location &optional content-type) - (let ((pages (lisplet-pages obj)) - (new-location (build-lisplet-location obj location))) - (setf (lisplet-pages obj) +(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type) + (let ((pages (lisplet-pages lisplet)) + (new-location (build-lisplet-location lisplet location))) + (setf (lisplet-pages lisplet) (sort-dispatchers (push-location-cons (cons new-location (if (directory-pathname-p resource-path) @@ -121,30 +184,28 @@ (create-static-file-dispatcher-and-handler new-location resource-path content-type))) pages))))) -(defmethod lisplet-dispatch-request ((obj lisplet)) - (let ((pages (lisplet-pages obj))) +(defmethod lisplet-dispatch-request ((lisplet lisplet)) + (let ((pages (lisplet-pages lisplet))) (loop for dispatcher in pages for action = (funcall (cdr dispatcher) *request*) - when action return (progn - ;; handle authentication - (funcall action))))) + when action return (funcall action)))) -(defmethod lisplet-dispatch-method ((obj lisplet)) +(defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((result nil) - (base-path (build-lisplet-location obj nil)) + (base-path (build-lisplet-location lisplet nil)) (uri (request-uri)) - (welcome-page (lisplet-welcome-page obj))) + (welcome-page (lisplet-welcome-page lisplet))) (progn - (setf (aux-request-value 'lisplet) obj) - (setf (aux-request-value 'realm) (lisplet-realm obj)) - (lisplet-check-authorization obj) + (setf (aux-request-value 'lisplet) lisplet) + (setf (aux-request-value 'realm) (lisplet-realm lisplet)) + (lisplet-check-authorization lisplet) (when (= (return-code) +http-ok+) (if (and welcome-page (string= uri base-path)) (progn - (redirect (lisplet-welcome-page obj)) + (redirect (lisplet-welcome-page lisplet)) t) (progn - (setf result (lisplet-dispatch-request obj)) + (setf result (lisplet-dispatch-request lisplet)) (when (null result) (setf (return-code) +http-not-found+)) result)))))) @@ -157,7 +218,8 @@ (cons new-location roles) protected-resources))))) -(defun redirect-to-https (server request) +(defun redirect-to-https (server request) + "Redirects a request sent through http using https" (cond ((= (server-port request) (clawserver-port server)) (progn @@ -204,6 +266,3 @@ (unless (user-in-role-p) (setf (return-code) +http-forbidden+) (throw 'handler-done nil)))))))) - -(defun lisplet-start-session () - (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet))))) \ No newline at end of file Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Fri Feb 15 10:12:46 2008 @@ -29,8 +29,10 @@ (in-package :claw) -(defvar *apache-http-port* 80) -(defvar *apache-https-port* 443) +(defvar *apache-http-port* 80 + "Default apache http port when claw is running in mod_lisp mode") +(defvar *apache-https-port* 443 + "Default apache https port when claw is running in mod_lisp mode") (defun strings-to-jsarray (strings) "Transforms a list of strings into a javascript array." Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Fri Feb 15 10:12:46 2008 @@ -230,6 +230,7 @@ :lisplet-protect :lisplet-authentication-type :lisplet-start-session + :lisplet-error-handlers :lisplet-redirect-protected-resources-p ;; clawserver :clawserver Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Fri Feb 15 10:12:46 2008 @@ -139,7 +139,7 @@ (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-pagep t) +(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") @@ -255,7 +255,7 @@ (aux-request-value 'password) (login-page-password login-page)) (login)) -(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-pagep t) +(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) (defclass form-page (page) ((name :initarg :name

1 0

[claw-cvs] r8 - trunk/main/claw-core/tests
by achiumenti＠common-lisp.net 15 Feb '08

15 Feb '08

Author: achiumenti Date: Fri Feb 15 07:53:35 2008 New Revision: 8 Modified: trunk/main/claw-core/tests/test1.lisp Log: updated tests Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Fri Feb 15 07:53:35 2008 @@ -43,11 +43,13 @@ -;;;(defparameter *clawserver* (make-instance 'clawserver :port 4242)) +;;(defparameter *clawserver* (make-instance 'clawserver :port 4242)) + (defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 :mod-lisp-p t :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) + (setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) (clawserver-register-lisplet *clawserver* *test-lisplet*)

1 0

[claw-cvs] r7 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 15 Feb '08

15 Feb '08

Author: achiumenti Date: Fri Feb 15 07:53:10 2008 New Revision: 7 Modified: 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/tags.lisp Log: added some comments, corrected some methods for authentication, corrected some naming conventions Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Fri Feb 15 07:53:10 2008 @@ -179,15 +179,16 @@ (login-config (current-config)) (login-page (lisplet-login-page lisplet)) (server (current-server request)) - (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) - (when (and auth-basicp (null princp)) - (configuration-login login-config)) - (setf (return-code) +http-ok+ - princp (current-principal)) - (when (and login-page - (cl-ppcre:all-matches login-page uri)) - (redirect-to-https server request)) - (loop for protected-resource in protected-resources + (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) + (setf (return-code) +http-ok+) + (when login-config + (when (and auth-basicp (null princp)) + (configuration-login login-config)) + (setf princp (current-principal)) + (when (and login-page + (cl-ppcre:all-matches login-page uri)) + (redirect-to-https server request)) + (loop for protected-resource in protected-resources for match = (format nil "^~a" (car protected-resource)) for allowed-roles = (cdr protected-resource) do (when (cl-ppcre:all-matches match uri) @@ -200,9 +201,9 @@ (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm))))) (setf (return-code) +http-authorization-required+) (throw 'handler-done nil)) - (unless (loop for role in (principal-roles princp) thereis (member role allowed-roles :test #'equal)) + (unless (user-in-role-p) (setf (return-code) +http-forbidden+) - (throw 'handler-done nil))))))) + (throw 'handler-done nil)))))))) (defun lisplet-start-session () (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet))))) \ No newline at end of file Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Fri Feb 15 07:53:10 2008 @@ -86,7 +86,7 @@ (when session (session-value 'principal session))) -(defun user-in-rolep (roles &optional (session *session*)) +(defun user-in-role-p (roles &optional (session *session*)) "Detects if current principal belongs to any of the expressed roles" (let ((principal (current-principal session))) (when principal Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Fri Feb 15 07:53:10 2008 @@ -48,7 +48,7 @@ ;:request-realm :request-id-table-map ;:dyna-id - :tag-empty-p + :tag-emptyp :tag-symbol-class :strings-to-jsarray :empty-string-p @@ -265,5 +265,5 @@ :current-lisplet :current-server :current-realm - :user-in-rolep + :user-in-role-p :login)) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Fri Feb 15 07:53:10 2008 @@ -31,206 +31,216 @@ -(defgeneric page-req-parameter (obj name &optional as-list) +(defgeneric page-req-parameter (page name &optional as-list) (:documentation "This method returns a request parameter given by NAME searching first into post parameters and, if no parameter found, into get prarmeters. The optional function parameter AS-LIST if true returns the result as list. When AS-LIST is true, if the searched parameter is found more then once, a list with all valuse given to param NAME is returned. - - OBJ is the page instance that must be given. + - PAGE is the page instance that must be given. - NAME The parameter to search - AS-LIST If true the result is returned as list, if false as string. Default: false")) -(defgeneric page-json-id-list (obj) +(defgeneric page-json-id-list (page) (:documentation "This internal method is called to get a list of all the components by their id, that must be updated when an xhr request is sent from the browser. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-content (obj) +(defgeneric page-content (page) (:documentation "This method returns the page content to be redered. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-init (obj) +(defgeneric page-init (page) (:documentation "Internal method for page initialization. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-render (obj) +(defgeneric page-render (page) (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-init-injections (pobj) +(defgeneric page-init-injections (page) (:documentation "This internal method is called during the request cycle phase to reset page slots that must be reinitialized during sub-phases (rewinding, pre-rendering, rendering). - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-render-headings (obj) +(defgeneric page-render-headings (page) (:documentation "This internal method renders the html first lines that determine if the page is a html or a xhtml, along with the schema definition. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-request-parameters (obj) +(defgeneric page-request-parameters (page) (:documentation "This internal method builds the get and post parameters into an hash table. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-print-tabulation (obj) +(defgeneric page-print-tabulation (page) (:documentation "This internal method is called during the rendering phase if tabulation is enabled. It writes the right amount of tabs chars to indent the page. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-newline (obj) +(defgeneric page-newline (page) (:documentation "This internal method simply writes the rest of page content on a new line when needed. - - OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric page-format (obj str &rest rest) +(defgeneric page-format (page str &rest rest) (:documentation "This internal method is the replacement of the FORMAT function. It is aware of an xhr request when the reply must be given as a json object. It also uses the default page output stream to render the output. - - OBJ is the page instance that must be given + - PAGE is the page instance that must be given - STR The format control - REST The format arguments See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) -(defgeneric page-format-raw (obj str &rest rest) +(defgeneric page-format-raw (page str &rest rest) (:documentation "This internal method is the replacement of the FORMAT. The difference with PAGE-FORMAT is that it prints out the result ignoring the json directive. It also uses the default page output stream as PAGE-FORMAT does to render the output. - - OBJ is the page instance that must be given + - PAGE is the page instance that must be given - STR The format control - REST The format arguments See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) -(defgeneric page-body-init-scripts (page-obj) +(defgeneric page-body-init-scripts (page) (:documentation "During the render phase wcomponent instances inject their initialization scripts (javascript) that will be evaluated when the page has been loaded. This internal method is called to render these scripts. - - PAGE-OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric htbody-init-scripts-tag (page-obj) +(defgeneric htbody-init-scripts-tag (page) (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component See PAGE-BODY-INIT-SCRIPTS form more info. - - PAGE-OBJ is the page instance that must be given")) + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-rewind (obj page-obj) +(defgeneric htcomponent-rewind (htcomponent page) (:documentation "This internal method is the first called during the request cycle phase. It is evaluated when a form action or an action-link action is fired. It is used to update all visit objects slots. - - OBJ is the htcomponent instance that must be rewound - - PAGE-OBJ is the page instance that must be given")) + - HTCOMPONENT is the htcomponent instance that must be rewound + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-prerender (obj page-obj) +(defgeneric htcomponent-prerender (htcomponent page) (:documentation "This internal method is the second sub phase during the request cycle phase. It is used to inject all wcomponent class scripts and stylesheets into the owner page. - - OBJ is the htcomponent instance that must be prerendered - - PAGE-OBJ is the page instance that must be given")) + - HTCOMPONENT is the htcomponent instance that must be prerendered + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-render (obj page-obj) +(defgeneric htcomponent-render (htcomponent page) (:documentation "This internal method is the last called during the request cycle phase. It is used to effectively render the component into the page. - - OBJ is the htcomponent instance that must be rendered - - PAGE-OBJ is the page instance that must be given")) + - HTCOMPONENT is the htcomponent instance that must be rendered + - PAGE is the page instance that must be given")) -(defgeneric htcomponent-can-print (obj) +(defgeneric htcomponent-can-print (htcomponent) (:documentation "This internal method is used in an xhr call to determine if a component may be rendered into the reply - - OBJ is the htcomponent instance")) + - HTCOMPONENT is the htcomponent instance")) -(defgeneric htcomponent-json-print-start-component (obj) +(defgeneric htcomponent-json-print-start-component (htcomponent) (:documentation "Internal method called to render the json reply during the render cycle phase on component start. - - OBJ is the htcomponent instance")) + - HTCOMPONENT is the htcomponent instance")) -(defgeneric htcomponent-json-print-end-component (obj) +(defgeneric htcomponent-json-print-end-component (htcomponent) (:documentation "Internal method called to render the json reply during the render cycle phase on component end. - - OBJ is the htcomponent instance")) + - HTCOMPONENT is the htcomponent instance")) -(defgeneric tag-render-starttag (obj page-obj) +(defgeneric tag-render-starttag (tag page) (:documentation "Internal method to print out the opening html tag during the render phase - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - TAG is the tag instance + - PAGE the page instance")) -(defgeneric tag-render-endtag (obj page-obj) +(defgeneric tag-render-endtag (tag page) (:documentation "Internal method to print out the closing html tag during the render phase - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - TAG is the tag instance + - PAGE the page instance")) -(defgeneric tag-render-attributes (obj page-obj) +(defgeneric tag-render-attributes (tag page) (:documentation "Internal method to print out the attributes of an html tag during the render phase - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - TAG is the tag instance + - PAGE the page instance")) -(defgeneric (setf htcomponent-page) (page-obj obj) +(defgeneric (setf htcomponent-page) (page htcomponent) (:documentation "Internal method to set the component owner page and to assign an unique id attribute when provided. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - HTCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-parameter-value (obj key) +(defgeneric wcomponent-parameter-value (wcomponent key) (:documentation "Returns the value of a parameter passed to the wcomponent initialization function (the one generated with DEFCOMPONENT) or :UNDEFINED if not passed. - - OBJ is the wcomponent instance + - WCOMPONENT is the wcomponent instance - KEY the parameter key to query")) -(defgeneric wcomponent-check-parameters(obj) +(defgeneric wcomponent-check-parameters(wcomponent) (:documentation "This internal method check if all :REQUIRED parameters are provided - - OBJ is the wcomponent instance")) + - WCOMPONENT is the wcomponent instance")) -(defgeneric wcomponent-parameters(obj) +(defgeneric wcomponent-parameters(wcomponent) (:documentation "This method returns class formal parameters as an alist (formal parameters are the ones expected by the component) - - OBJ is the wcomponent instance")) -(defgeneric wcomponent-informal-parameters(obj) + - WCOMPONENT is the wcomponent instance")) + +(defgeneric wcomponent-informal-parameters(wcomponent) (:documentation "This method returns class informal parameters as an alist (informal parameters are the ones not expected by the component, usually rendered as tag attributes withot any kind of evaluation) - - OBJ is the wcomponent instance")) + - WCOMPONENT is the wcomponent instance")) -(defgeneric wcomponent-before-rewind (obj page-obj) +(defgeneric wcomponent-before-rewind (wcomponent page) (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - WCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-after-rewind (obj page-obj) +(defgeneric wcomponent-after-rewind (wcomponent page) (:documentation "Method called by the framework after the rewinding phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) -(defgeneric wcomponent-before-prerender (obj page-obj) + - WCOMPONENT is the tag instance + - PAGE the page instance")) +(defgeneric wcomponent-before-prerender (wcomponent page) (:documentation "Method called by the framework before the pre-rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - WCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-after-prerender (obj page-obj) +(defgeneric wcomponent-after-prerender (wcomponent page) (:documentation "Method called by the framework after the pre-rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) -(defgeneric wcomponent-before-render (obj page-obj) + - WCOMPONENT is the tag instance + - PAGE the page instance")) +(defgeneric wcomponent-before-render (wcomponent page) (:documentation "Method called by the framework before the rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - WCOMPONENT is the tag instance + - PAGE the page instance")) -(defgeneric wcomponent-after-render (obj page-obj) +(defgeneric wcomponent-after-render (wcomponent page) (:documentation "Method called by the framework after the rendering phase. It is intended to be eventually overridden in descendant classes. - - OBJ is the tag instance - - PAGE-OBJ the page instance")) + - 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") +(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") -(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" "Page doctype as HTML 4.01 TRANSITIONAL") +(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" + "Page doctype as HTML 4.01 TRANSITIONAL") -(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" "Page doctype as HTML 4.01 FRAMESET") +(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" + "Page doctype as HTML 4.01 FRAMESET") -(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" "Page doctype as HTML 4.01 XHTML") +(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" + "Page doctype as HTML 4.01 XHTML") -(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" "Page doctype as XHTML 4.01 TRANSITIONAL") +(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" + "Page doctype as XHTML 4.01 TRANSITIONAL") -(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" "Page doctype as XHTML 4.01 FRAMESET") +(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" + "Page doctype as XHTML 4.01 FRAMESET") -(defvar *default-encoding* "UTF-8" "Page default encoding (if no changes 'UTF-8')") +(defvar *default-encoding* "UTF-8" + "Page default encoding (if no changes 'UTF-8')") -(defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action") +(defvar *rewind-parameter* "rewindobject" + "The request parameter for the object asking for a rewind action") (defvar *empty-tags* (list "area" "base" "basefont" "br" "col" "frame" "hr" "img" "input" "isindex" "meta" - "param" "link")) + "param" "link") + "List of html empty tags") (defun request-id-table-map () "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. @@ -277,11 +287,11 @@ (setf (gethash id id-ht) (1+ client-id-index)) result)) -(defun build-tagf (tag-name parent empty-p &rest rest) +(defun build-tagf (tag-name parent emptyp &rest rest) "This function is used to create a tag object instance - TAG-NAME the a string tag name to create, for example \"span\" - PARENT the parent class. usually 'TAG -- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase. +- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase. - REST a list of attribute/value pairs and the component body" (let* ((fbody (parse-htcomponent-function (flatten rest))) (id-table-map (request-id-table-map)) @@ -292,7 +302,7 @@ (remf (first fbody) :id) (setf id nil)) (setf instance (make-instance parent - :empty empty-p + :empty emptyp :name (string-downcase tag-name) :attributes (first fbody) :body (second fbody))) @@ -303,18 +313,16 @@ (setf (htcomponent-client-id instance) static-id)) instance)) -(defun generate-tagf (tag-name empty-p) +(defun generate-tagf (tag-name emptyp) "Internal function that generates an htcomponent creation function from the component class name - TAG-NAME the symbol class name of the component -- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase." +- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase." (setf (fdefinition (intern (format nil "~a>" (string-upcase tag-name)))) - #'(lambda (&rest rest) (build-tagf tag-name 'tag empty-p rest)))) + #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest)))) ;;;---------------------------------------------------------------- - - (defclass page() ((writer :initarg :writer :accessor page-writer :documentation "The output stream for this page instance") @@ -362,7 +370,6 @@ (:documentation "A page object holds claw components to be rendered") ) (defclass htcomponent () - ;class for html tags ((page :initarg :page :reader htcomponent-page :documentation "The owner page") (body :initarg :body @@ -405,9 +412,9 @@ (:documentation "Component needed to render strings")) (defmethod initialize-instance :after ((inst tag) &rest keys) - (let ((empty-p (getf keys :empty)) + (let ((emptyp (getf keys :empty)) (body (getf keys :body))) - (when (and (not (null empty-p)) + (when (and (not (null emptyp)) (not (null body))) (error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body))))) @@ -445,9 +452,7 @@ (mapcar #'(lambda (tag-name) (generate-tagf tag-name t)) ;;Creates empty tag initialization functions. But the ones directly defined - '("area" "base" "basefont" "br" "col" "frame" - "hr" "img" "input" "isindex" "meta" - "param")) + *empty-tags*) (mapcar #'(lambda (tag-name) (generate-tagf tag-name nil)) ;;Creates non empty tag initialization functions. But the ones directly defined @@ -470,7 +475,7 @@ "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" "u" "ul" "var")) -(defun tag-empty-p (tag-name) +(defun tag-emptyp (tag-name) "Returns if a tag defined by the string TAG-NAME is empty" (member tag-name *empty-tags* :test #'string-equal)) @@ -484,29 +489,29 @@ (t 'tag)))) ;;;--------------------METHODS implementation---------------------------------------------- -(defmethod (setf htcomponent-page) ((pobj page) (obj htcomponent)) - (let ((id (getf (htcomponent-attributes obj) :id)) - (static-id (getf (htcomponent-attributes obj) :static-id)) - (client-id (htcomponent-client-id obj))) - (setf (slot-value obj 'page) pobj) +(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) + (let ((id (getf (htcomponent-attributes htcomponent) :id)) + (static-id (getf (htcomponent-attributes htcomponent) :static-id)) + (client-id (htcomponent-client-id htcomponent))) + (setf (slot-value htcomponent 'page) page) (unless client-id (if static-id - (setf (htcomponent-client-id obj) static-id) - (setf (htcomponent-client-id obj) (generate-id id)))))) + (setf (htcomponent-client-id htcomponent) static-id) + (setf (htcomponent-client-id htcomponent) (generate-id id)))))) -(defmethod page-request-parameters ((pobj page)) - (if (and (boundp '*request*) (null (slot-value pobj 'request-parameters))) +(defmethod page-request-parameters ((page page)) + (if (and (boundp '*request*) (null (slot-value page 'request-parameters))) (let ((parameters (append (post-parameters) (get-parameters))) (pparameters (make-hash-table :test 'equal))) (loop for kv in parameters do (setf (gethash (string-upcase (car kv)) pparameters) (append (gethash (string-upcase (car kv)) pparameters) (list (cdr kv))))) - (setf (slot-value pobj 'request-parameters) pparameters)) - (slot-value pobj 'request-parameters))) + (setf (slot-value page 'request-parameters) pparameters)) + (slot-value page 'request-parameters))) -(defmethod page-req-parameter ((pobj page) name &optional as-list) - (let ((parameters (page-request-parameters pobj)) +(defmethod page-req-parameter ((page page) name &optional as-list) + (let ((parameters (page-request-parameters page)) (retval)) (when parameters (setf retval (gethash (string-upcase name) parameters)) @@ -514,10 +519,10 @@ retval (first retval))))) -(defmethod page-format ((obj page) str &rest rest) - (let ((json-p (page-json-id-list obj)) - (writer (page-writer obj))) - (if (null json-p) +(defmethod page-format ((page page) str &rest rest) + (let ((jsonp (page-json-id-list page)) + (writer (page-writer page))) + (if (null jsonp) (apply #'format writer str rest) (apply #'format writer (list (regex-replace-all "\"" @@ -528,101 +533,98 @@ "\\\\\\\"") "\\\"")))))) -(defmethod page-format-raw ((obj page) str &rest rest) - (let ((writer (page-writer obj))) +(defmethod page-format-raw ((page page) str &rest rest) + (let ((writer (page-writer page))) (apply #'format writer str rest))) -(defmethod page-json-id-list ((obj page)) - (page-req-parameter obj "json" t)) +(defmethod page-json-id-list ((page page)) + (page-req-parameter page "json" t)) -(defmethod page-init ((obj page)) +(defmethod page-init ((page page)) (progn (reset-request-id-table-map) - (setf (page-can-print obj) (null (page-json-id-list obj))) + (setf (page-can-print page) (null (page-json-id-list page))) (reset-request-id-table-map) - (setf (page-tabulator obj) 0))) + (setf (page-tabulator page) 0))) -(defmethod page-render-headings ((obj page)) - (let* ((writer (page-writer obj)) - (json-p (page-json-id-list obj)) +(defmethod page-render-headings ((page page)) + (let* ((writer (page-writer page)) + (jsonp (page-json-id-list page)) (encoding (handler-case (format nil "~a" (stream-external-format writer)) (error () (format nil "~a" *default-encoding*)))) - (xml-p (page-xmloutput obj)) - (content-type (page-doc-type obj))) - (when (null json-p) + (xml-p (page-xmloutput page)) + (content-type (page-doc-type page))) + (when (null jsonp) (when xml-p - (page-format-raw obj "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) + (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) (when content-type - (page-format-raw obj "~a~%" content-type))))) + (page-format-raw page "~a~%" content-type))))) -(defmethod page-render ((obj page)) - (let ((body (page-content obj)) - (json-p (page-json-id-list obj))) +(defmethod page-render ((page page)) + (let ((body (page-content page)) + (jsonp (page-json-id-list page))) (if (null body) - (format nil "null body for page ~a~%" (type-of obj)) + (format nil "null body for page ~a~%" (type-of page)) (progn - (page-init obj) - (when (page-req-parameter obj *rewind-parameter*) - (htcomponent-rewind body obj)) - (page-init obj) - (htcomponent-prerender (page-content obj) obj) ;Here we need a fresh new body!!! - (page-render-headings obj) - (page-init obj) - (when json-p - (page-format-raw obj "{components:{")) - - (setf (page-can-print obj) t) - (htcomponent-render (page-content obj) obj) ;Here we need a fresh new body!!! - (when json-p - (page-format-raw obj "},classInjections:\"") - (setf (page-can-print obj) t) - (dolist (injection (page-init-injections obj)) - (htcomponent-render injection obj)) - (page-format-raw obj "\",instanceInjections:\"") - (htcomponent-render (htbody-init-scripts-tag obj) obj) - (page-format-raw obj "\"}")))))) + (page-init page) + (when (page-req-parameter page *rewind-parameter*) + (htcomponent-rewind body page)) + (page-init page) + (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! + (page-render-headings page) + (page-init page) + (when jsonp + (page-format-raw page "{components:{")) + (setf (page-can-print page) t) + (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! + (when jsonp + (page-format-raw page "},classInjections:\"") + (setf (page-can-print page) t) + (dolist (injection (page-init-injections page)) + (htcomponent-render injection page)) + (page-format-raw page "\",instanceInjections:\"") + (htcomponent-render (htbody-init-scripts-tag page) page) + (page-format-raw page "\"}")))))) -(defmethod page-body-init-scripts ((pobj page)) +(defmethod page-body-init-scripts ((page page)) (let ((js-body "")) - (dolist (current-js (reverse (page-instance-initscripts pobj))) + (dolist (current-js (reverse (page-instance-initscripts page))) (setf js-body (format nil "~a~%~a~%" js-body current-js))) (if (string= "" js-body) js-body (format nil "~a" js-body)))) -(defmethod page-print-tabulation ((obj page)) - (let ((json-p (page-json-id-list obj)) - (tabulator (page-tabulator obj)) - (indent-p (page-indent obj))) - (when (and (<= 0 tabulator) indent-p (null json-p)) - (page-format-raw obj "~a" +(defmethod page-print-tabulation ((page page)) + (let ((jsonp (page-json-id-list page)) + (tabulator (page-tabulator page)) + (indent-p (page-indent page))) + (when (and (<= 0 tabulator) indent-p (null jsonp)) + (page-format-raw page "~a" (make-string tabulator :initial-element #\tab))))) -(defmethod page-newline ((obj page)) - (let ((json-p (page-json-id-list obj)) - (indent-p (page-indent obj))) - (when (and indent-p (null json-p)) - (page-format-raw obj "~%")))) +(defmethod page-newline ((page page)) + (let ((jsonp (page-json-id-list page)) + (indent-p (page-indent page))) + (when (and indent-p (null jsonp)) + (page-format-raw page "~%")))) -(defmethod page-init-injections ((pobj page)) +(defmethod page-init-injections ((page page)) (let ((tag-list) (class-init-scripts "")) - - (dolist (script (reverse (page-class-initscripts pobj))) + (dolist (script (reverse (page-class-initscripts page))) (setf class-init-scripts (format nil "~a~%~a" class-init-scripts script))) (unless (string= "" class-init-scripts) (let ((current-js (script> :type "text/javascript"))) (setf (htcomponent-body current-js) class-init-scripts) - (push current-js tag-list))) - - (dolist (js-file (page-script-files pobj)) + (push current-js tag-list))) + (dolist (js-file (page-script-files page)) (let ((current-js (script> :type "text/javascript" :src ""))) (setf (getf (htcomponent-attributes current-js) :src) js-file) (push current-js tag-list))) - (dolist (css-file (page-stylesheet-files pobj)) + (dolist (css-file (page-stylesheet-files page)) (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) (setf (getf (htcomponent-attributes current-css) :href) css-file) (push current-css tag-list))) @@ -630,161 +632,162 @@ tag-list)) ;;;========= HTCOMPONENT ============================ -(defmethod htcomponent-can-print ((obj htcomponent)) - (let* ((id (htcomponent-client-id obj)) - (pobj (htcomponent-page obj)) - (print-status (page-can-print pobj)) - (render-p (member id (page-json-id-list pobj) :test #'string=))) +(defmethod htcomponent-can-print ((htcomponent htcomponent)) + (let* ((id (htcomponent-client-id htcomponent)) + (page (htcomponent-page htcomponent)) + (print-status (page-can-print page)) + (render-p (member id (page-json-id-list page) :test #'string=))) (or print-status render-p))) -(defmethod htcomponent-json-print-start-component ((obj htcomponent)) - (let* ((pobj (htcomponent-page obj)) - (json-p (page-json-id-list pobj)) - (id (htcomponent-client-id obj))) - (when (or json-p - (member id json-p :test #'string-equal)) - (when (> (page-json-component-count pobj) 0) - (page-format pobj ",")) - (page-format-raw pobj "~a:\"" id) - (incf (page-json-component-count pobj))))) - -(defmethod htcomponent-json-print-end-component ((obj htcomponent)) - (let* ((pobj (htcomponent-page obj)) - (json-p (page-json-id-list pobj)) - (id (htcomponent-client-id obj))) - (when (or json-p - (member id json-p :test #'string-equal)) - (page-format-raw pobj "\"")))) - -(defmethod htcomponent-rewind :before ((obj htcomponent) (pobj page)) - (setf (htcomponent-page obj) pobj)) -(defmethod htcomponent-prerender :before ((obj htcomponent) (pobj page)) - (setf (htcomponent-page obj) pobj)) -(defmethod htcomponent-render :before ((obj htcomponent) (pobj page)) - (setf (htcomponent-page obj) pobj)) +(defmethod htcomponent-json-print-start-component ((htcomponent htcomponent)) + (let* ((page (htcomponent-page htcomponent)) + (jsonp (page-json-id-list page)) + (id (htcomponent-client-id htcomponent))) + (when (or jsonp + (member id jsonp :test #'string-equal)) + (when (> (page-json-component-count page) 0) + (page-format page ",")) + (page-format-raw page "~a:\"" id) + (incf (page-json-component-count page))))) + +(defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) + (let* ((page (htcomponent-page htcomponent)) + (jsonp (page-json-id-list page)) + (id (htcomponent-client-id htcomponent))) + (when (or jsonp + (member id jsonp :test #'string-equal)) + (page-format-raw page "\"")))) + +(defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) + (setf (htcomponent-page htcomponent) page)) + +(defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page)) + (setf (htcomponent-page htcomponent) page)) + +(defmethod htcomponent-render :before ((htcomponent htcomponent) (page page)) + (setf (htcomponent-page htcomponent) page)) -(defmethod htcomponent-rewind ((obj htcomponent) (pobj page)) - (dolist (tag (htcomponent-body obj)) +(defmethod htcomponent-rewind ((htcomponent htcomponent) (page page)) + (dolist (tag (htcomponent-body htcomponent)) (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-rewind tag pobj)))) + (htcomponent-rewind tag page)))) -(defmethod htcomponent-prerender ((obj htcomponent) (pobj page)) - (let ((previous-print-status (page-can-print pobj))) -; (log-message :info "------------------- ~a" previous-print-status) +(defmethod htcomponent-prerender ((htcomponent htcomponent) (page page)) + (let ((previous-print-status (page-can-print page))) (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj))) - (dolist (tag (htcomponent-body obj)) + (setf (page-can-print page) (htcomponent-can-print htcomponent))) + (dolist (tag (htcomponent-body htcomponent)) (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag pobj))) + (htcomponent-prerender tag page))) (when (null previous-print-status) - (setf (page-can-print pobj) nil)))) + (setf (page-can-print page) nil)))) -(defmethod htcomponent-render ((obj htcomponent) (pobj page)) - (let ((body-list (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) +(defmethod htcomponent-render ((htcomponent htcomponent) (page page)) + (let ((body-list (htcomponent-body htcomponent)) + (previous-print-status (page-can-print page))) (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) + (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) pobj) - (htcomponent-render tag pobj))) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) (when (null previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htcomponent)))) ;;;========= TAG ===================================== -(defmethod tag-render-attributes ((obj tag) (pobj page)) - (when (htcomponent-attributes obj) - (loop for (k v) on (htcomponent-attributes obj) by #'cddr +(defmethod tag-render-attributes ((tag tag) (page page)) + (when (htcomponent-attributes tag) + (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn (assert (keywordp k)) (when v - (page-format pobj " ~a=\"~a\"" + (page-format page " ~a=\"~a\"" (string-downcase (if (eq k :static-id) "id" (symbol-name k))) (let ((s (if (eq k :id) - (prin1-to-string (htcomponent-client-id obj)) + (prin1-to-string (htcomponent-client-id tag)) (prin1-to-string v)))) ;escapes double quotes (subseq s 1 (1- (length s)))))))))) -(defmethod tag-render-starttag ((obj tag) (pobj page)) - (let ((tagname (tag-name obj)) - (empty-p (htcomponent-empty obj)) - (xml-p (page-xmloutput pobj))) - (setf (page-lasttag pobj) tagname) - (page-newline pobj) - (page-print-tabulation pobj) - (page-format pobj "<~a" tagname) - (tag-render-attributes obj pobj) - (if (null empty-p) +(defmethod tag-render-starttag ((tag tag) (page page)) + (let ((tagname (tag-name tag)) + (emptyp (htcomponent-empty tag)) + (xml-p (page-xmloutput page))) + (setf (page-lasttag page) tagname) + (page-newline page) + (page-print-tabulation page) + (page-format page "<~a" tagname) + (tag-render-attributes tag page) + (if (null emptyp) (progn - (page-format pobj ">") - (incf (page-tabulator pobj))) + (page-format page ">") + (incf (page-tabulator page))) (if (null xml-p) - (page-format pobj ">") - (page-format pobj "/>"))))) + (page-format page ">") + (page-format page "/>"))))) -(defmethod tag-render-endtag ((obj tag) (pobj page)) - (let ((tagname (tag-name obj)) - (previous-tagname (page-lasttag pobj)) - (empty-p (htcomponent-empty obj))) - (when (null empty-p) +(defmethod tag-render-endtag ((tag tag) (page page)) + (let ((tagname (tag-name tag)) + (previous-tagname (page-lasttag page)) + (emptyp (htcomponent-empty tag))) + (when (null emptyp) (progn - (decf (page-tabulator pobj)) + (decf (page-tabulator page)) (if (string= tagname previous-tagname) (progn - (page-format pobj "</~a>" tagname)) + (page-format page "</~a>" tagname)) (progn - (page-newline pobj) - (page-print-tabulation pobj) - (page-format pobj "</~a>" tagname))))) - (setf (page-lasttag pobj) nil))) - -(defmethod htcomponent-render ((obj tag) (pobj page)) - (let ((body-list (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (when (or (page-can-print pobj) previous-print-status) - (tag-render-starttag obj pobj)) + (page-newline page) + (page-print-tabulation page) + (page-format page "</~a>" tagname))))) + (setf (page-lasttag page) nil))) + +(defmethod htcomponent-render ((tag tag) (page page)) + (let ((body-list (htcomponent-body tag)) + (previous-print-status (page-can-print page))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print tag)) + (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) pobj) - (htcomponent-render tag pobj))) - (when (or (page-can-print pobj) previous-print-status) - (tag-render-endtag obj pobj)) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) + (when (or (page-can-print page) previous-print-status) + (tag-render-endtag tag page)) (unless previous-print-status - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component tag)))) ;;;========= HTHEAD ====================================== -(defmethod htcomponent-render ((obj hthead) (pobj page)) - (when (null (page-json-id-list pobj)) - (let ((body-list (htcomponent-body obj)) - (injections (page-init-injections pobj))) - (tag-render-starttag obj pobj) +(defmethod htcomponent-render ((hthead hthead) (page page)) + (when (null (page-json-id-list page)) + (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) pobj) - (htcomponent-render tag pobj))) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) (dolist (injection injections) - (htcomponent-render injection pobj)) - (tag-render-endtag obj pobj)))) + (htcomponent-render injection page)) + (tag-render-endtag hthead page)))) ;;;========= HTSTRING =================================== -(defmethod htcomponent-rewind((obj htstring) (pobj page))) -(defmethod htcomponent-prerender((obj htstring) (pobj page))) +(defmethod htcomponent-rewind((htstring htstring) (page page))) +(defmethod htcomponent-prerender((htstring htstring) (page page))) -(defmethod htcomponent-render ((obj htstring) (pobj page)) - (let ((body (htcomponent-body obj)) - (json-p (not (null (page-json-id-list pobj)))) - (print-p (page-can-print pobj))) +(defmethod htcomponent-render ((htstring htstring) (page page)) + (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 json-p + (when jsonp (setf body (regex-replace-all "\"" (regex-replace-all "\\\\\"" (regex-replace-all "\\n" @@ -792,91 +795,91 @@ "\\n") "\\\\\\\"") "\\\""))) - (if (htstring-raw obj) - (page-format-raw pobj body) + (if (htstring-raw htstring) + (page-format-raw page body) (loop for ch across body do (case ch - ((#\<) (page-format-raw pobj "<")) - ((#\>) (page-format-raw pobj ">")) - ((#\&) (page-format-raw pobj "&")) - (t (page-format-raw pobj "~a" ch)))))))) + ((#\<) (page-format-raw page "<")) + ((#\>) (page-format-raw page ">")) + ((#\&) (page-format-raw page "&")) + (t (page-format-raw page "~a" ch)))))))) ;;;========= HTSCRIPT =================================== -(defmethod htcomponent-prerender((obj htscript) (pobj page))) +(defmethod htcomponent-prerender((htscript htscript) (page page))) -(defmethod htcomponent-render ((obj htscript) (pobj page)) - (let ((xml-p (page-xmloutput pobj)) - (body (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (unless (getf (htcomponent-attributes obj) :type) - (append '(:type "text/javascript") (htcomponent-attributes obj))) - (when (page-can-print pobj) - (tag-render-starttag obj pobj) - (when (and (null (getf (htcomponent-attributes obj) :src)) - (not (null (htcomponent-body obj)))) +(defmethod htcomponent-render ((htscript htscript) (page page)) + (let ((xml-p (page-xmloutput page)) + (body (htcomponent-body htscript)) + (previous-print-status (page-can-print page))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htscript)) + (htcomponent-json-print-start-component htscript)) + (unless (getf (htcomponent-attributes htscript) :type) + (append '(:type "text/javascript") (htcomponent-attributes htscript))) + (when (page-can-print page) + (tag-render-starttag htscript page) + (when (and (null (getf (htcomponent-attributes htscript) :src)) + (not (null (htcomponent-body htscript)))) (if (null xml-p) - (page-format pobj "~%//") - (page-format pobj "~%//]]>"))) - (setf (page-lasttag pobj) nil) - (tag-render-endtag obj pobj)) + (page-format page "~%//-->") + (page-format page "~%//]]>"))) + (setf (page-lasttag page) nil) + (tag-render-endtag htscript page)) (when (null previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htscript)))) ;;;========= HTLINK ==================================== -(defmethod htcomponent-render ((obj htlink) (pobj page)) - (let ((previous-print-status (page-can-print pobj))) +(defmethod htcomponent-render ((htlink htlink) (page page)) + (let ((previous-print-status (page-can-print page))) (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (when (page-can-print pobj) - (unless (getf (htcomponent-attributes obj) :type) - (append '(:type "text/css") (htcomponent-attributes obj))) - (unless (getf (htcomponent-attributes obj) :rel) - (append '(:rel "styleshhet") (htcomponent-attributes obj))) - (tag-render-starttag obj pobj) - (tag-render-endtag obj pobj)) + (setf (page-can-print page) (htcomponent-can-print htlink)) + (htcomponent-json-print-start-component htlink)) + (when (page-can-print page) + (unless (getf (htcomponent-attributes htlink) :type) + (append '(:type "text/css") (htcomponent-attributes htlink))) + (unless (getf (htcomponent-attributes htlink) :rel) + (append '(:rel "styleshhet") (htcomponent-attributes htlink))) + (tag-render-starttag htlink page) + (tag-render-endtag htlink page)) (when (null previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htlink)))) ;;;========= HTBODY =================================== -(defmethod htcomponent-render ((obj htbody) (pobj page)) - (let ((body-list (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) - (when (or (page-can-print pobj) previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (when (page-can-print pobj) - (tag-render-starttag obj pobj)) +(defmethod htcomponent-render ((htbody htbody) (page page)) + (let ((body-list (htcomponent-body htbody)) + (previous-print-status (page-can-print page))) + (when (or (page-can-print page) previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htbody)) + (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) pobj) - (htcomponent-render tag pobj))) - (when (page-can-print pobj) - (htcomponent-render (htbody-init-scripts-tag pobj) pobj) - (tag-render-endtag obj pobj)) - (when (or (page-can-print pobj) previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) + (when (page-can-print page) + (htcomponent-render (htbody-init-scripts-tag page) page) + (tag-render-endtag htbody page)) + (when (or (page-can-print page) previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htbody)))) -(defmethod htbody-init-scripts-tag ((pobj page)) +(defmethod htbody-init-scripts-tag ((page page)) (let ((js (script> :type "text/javascript"))) - (setf (htcomponent-page js) pobj) - (setf (htcomponent-body js) (page-body-init-scripts pobj)) + (setf (htcomponent-page js) page) + (setf (htcomponent-body js) (page-body-init-scripts page)) js)) ;;;========= WCOMPONENT =================================== @@ -985,62 +988,62 @@ (setf (fdefinition `,',symbolf) #'(lambda(&rest rest) (build-component ',name rest)))))) -(defmethod htcomponent-rewind ((obj wcomponent) (pobj page)) - (let ((template (wcomponent-template obj))) - (wcomponent-before-rewind obj pobj) +(defmethod htcomponent-rewind ((wcomponent wcomponent) (page page)) + (let ((template (wcomponent-template wcomponent))) + (wcomponent-before-rewind wcomponent page) (if (listp template) (dolist (tag template) - (htcomponent-rewind tag pobj)) - (htcomponent-rewind template pobj)) - (wcomponent-after-rewind obj pobj))) - -(defmethod wcomponent-before-rewind ((obj wcomponent) (pobj page))) -(defmethod wcomponent-after-rewind ((obj wcomponent) (pobj page))) - -(defmethod htcomponent-prerender ((obj wcomponent) (pobj page)) - (wcomponent-before-prerender obj pobj) - (let ((previous-print-status (page-can-print pobj)) - (template (wcomponent-template obj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj))) - (when (page-can-print pobj) - (dolist (script (htcomponent-script-files obj)) - (pushnew script (page-script-files pobj) :test #'equal)) - (dolist (css (htcomponent-stylesheet-files obj)) - (pushnew css (page-stylesheet-files pobj) :test #'equal)) - (dolist (js (htcomponent-class-initscripts obj)) - (pushnew js (page-class-initscripts pobj) :test #'equal)) - (when (htcomponent-instance-initscript obj) - (pushnew (htcomponent-instance-initscript obj) (page-instance-initscripts pobj) :test #'equal))) + (htcomponent-rewind tag page)) + (htcomponent-rewind template page)) + (wcomponent-after-rewind wcomponent page))) + +(defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page))) +(defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page))) + +(defmethod htcomponent-prerender ((wcomponent wcomponent) (page page)) + (wcomponent-before-prerender wcomponent page) + (let ((previous-print-status (page-can-print page)) + (template (wcomponent-template wcomponent))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print wcomponent))) + (when (page-can-print page) + (dolist (script (htcomponent-script-files wcomponent)) + (pushnew script (page-script-files page) :test #'equal)) + (dolist (css (htcomponent-stylesheet-files wcomponent)) + (pushnew css (page-stylesheet-files page) :test #'equal)) + (dolist (js (htcomponent-class-initscripts wcomponent)) + (pushnew js (page-class-initscripts page) :test #'equal)) + (when (htcomponent-instance-initscript wcomponent) + (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) (if (listp template) (dolist (tag template) (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag pobj))) - (htcomponent-prerender template pobj)) + (htcomponent-prerender tag page))) + (htcomponent-prerender template page)) (when (null previous-print-status) - (setf (page-can-print pobj) nil))) - (wcomponent-after-prerender obj pobj)) + (setf (page-can-print page) nil))) + (wcomponent-after-prerender wcomponent page)) -(defmethod wcomponent-before-prerender ((obj wcomponent) (pobj page))) -(defmethod wcomponent-after-prerender ((obj wcomponent) (pobj page))) +(defmethod wcomponent-before-prerender ((wcomponent wcomponent) (page page))) +(defmethod wcomponent-after-prerender ((wcomponent wcomponent) (page page))) -(defmethod htcomponent-render ((obj wcomponent) (pobj page)) - (let ((template (wcomponent-template obj)) - (previous-print-status (page-can-print pobj))) - (when (null previous-print-status) - (setf (page-can-print pobj) (htcomponent-can-print obj)) - (htcomponent-json-print-start-component obj)) - (wcomponent-before-render obj pobj) +(defmethod htcomponent-render ((wcomponent wcomponent) (page page)) + (let ((template (wcomponent-template wcomponent)) + (previous-print-status (page-can-print page))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print wcomponent)) + (htcomponent-json-print-start-component wcomponent)) + (wcomponent-before-render wcomponent page) (unless (listp template) (setf template (list template))) (dolist (tag template) (if (stringp tag) - (htcomponent-render ($> tag) pobj) - (htcomponent-render tag pobj))) - (wcomponent-after-render obj pobj) + (htcomponent-render ($> tag) page) + (htcomponent-render tag page))) + (wcomponent-after-render wcomponent page) (when (null previous-print-status) - (setf (page-can-print pobj) nil) - (htcomponent-json-print-end-component obj)))) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component wcomponent)))) -(defmethod wcomponent-before-render ((obj wcomponent) (pobj page))) -(defmethod wcomponent-after-render ((obj wcomponent) (pobj page))) +(defmethod wcomponent-before-render ((wcomponent wcomponent) (page page))) +(defmethod wcomponent-after-render ((wcomponent wcomponent) (page page)))

1 0

[claw-cvs] r6 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 15 Feb '08

15 Feb '08

Author: achiumenti Date: Fri Feb 15 06:13:45 2008 New Revision: 6 Modified: trunk/main/claw-core/src/misc.lisp Log: added some comments Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Fri Feb 15 06:13:45 2008 @@ -70,25 +70,32 @@ (setf result (push location-cons cons-list)))) (defun current-realm (&optional (request *request*)) + "Returns the realm under which the request has been sent" (aux-request-value 'realm request)) (defun current-lisplet (&optional (request *request*)) + "Returns the lisplet instance from which the request comes from" (aux-request-value 'lisplet request)) (defun current-server (&optional (request *request*)) + "Returns the clawserver instance from which the request comes from" (aux-request-value 'clawserver request)) (defun current-principal (&optional (session *session*)) + "Returns the principal(user) that logged into the application" (when session - (session-value 'principal))) + (session-value 'principal session))) (defun user-in-rolep (roles &optional (session *session*)) + "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))))) (defun current-config (&optional (request *request*)) - (gethash (current-realm request) (clawserver-login-config (current-server)))) + "Returns the current configuration object for the realm of the request" + (gethash (current-realm request) (clawserver-login-config (current-server request)))) (defun login (&optional (request *request*)) + "Perfoms a login action using the configuration object given for the request realm" (configuration-login (current-config request))) \ No newline at end of file

1 0