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

[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

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

15 Feb '08

Author: achiumenti Date: Fri Feb 15 05:27:29 2008 New Revision: 5 Added: trunk/main/claw-core/tests/img/ trunk/main/claw-core/tests/img/matrix.jpg (contents, props changed) 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/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/tests/test1.lisp Log: added authentication/authorization 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 05:27:29 2008 @@ -31,27 +31,43 @@ ;(print *this-file*) -(defgeneric lisplet-register-function-location (obj function location &optional welcome-pagep)) -(defgeneric lisplet-register-page-location (obj page-class location &optional welcome-pagep)) +(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)) + +(setf *http-error-handler* + #'(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))))) (defclass lisplet () ((base-path :initarg :base-path :reader lisplet-base-path) (welcome-page :initarg :welcome-page :accessor lisplet-welcome-page) + (login-page :initarg :login-page + :accessor lisplet-login-page) (realm :initarg :realm :reader lisplet-realm) (pages :initform nil :accessor lisplet-pages) - (page404 :initarg :page404 - :accessor lisplet-page404)) - (:default-initargs :welcome-page nil :realm nil :page404 (make-instance 'page404))) + (protected-resources :initform nil + :accessor lisplet-protected-resources) + (redirect-protected-resources-p :initarg :redirect-protected-resources-p + :accessor lisplet-redirect-protected-resources-p)) + (:default-initargs :welcome-page nil + :login-page nil + :realm "claw" + :redirect-protected-resources-p nil)) (defun build-lisplet-location (lisplet location) (let ((server-base-path *clawserver-base-path*) @@ -63,39 +79,27 @@ (setf location (format nil "~a~a" server-base-path location))) location)) -(defmethod lisplet-register-function-location ((obj lisplet) function location &optional welcome-pagep) +(defmethod lisplet-authentication-type ((lisplet lisplet)) + (if (lisplet-login-page lisplet) + :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) - (sort-dispatchers (push-dispatcher + (sort-dispatchers (push-location-cons (cons new-location (create-prefix-dispatcher new-location function (lisplet-realm obj))) pages))) (when welcome-pagep - (setf (lisplet-welcome-page obj) new-location)))) + (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 &optional welcome-pagep content-type) - (let ((pages (lisplet-pages obj)) - (new-location (build-lisplet-location obj location))) - (setf (lisplet-pages obj) - (sort-dispatchers (push-dispatcher - (cons new-location - (create-prefix-dispatcher new-location - #'(lambda () - (with-output-to-string - (*standard-output*) - (page-render (make-instance page-class :lisplet obj :url new-location)))) - (lisplet-realm obj) - content-type)) - pages))) - (when welcome-pagep - (setf (lisplet-welcome-page obj) new-location)))) -|# - -(defmethod lisplet-register-page-location ((obj lisplet) page-class location &optional welcome-pagep) +(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 #'(lambda () @@ -103,13 +107,14 @@ (*standard-output*) (page-render (make-instance page-class :lisplet obj :url new-location)))) location - welcome-pagep))) + :welcome-pagep welcome-pagep + :login-pagep login-pagep))) (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) - (sort-dispatchers (push-dispatcher + (sort-dispatchers (push-location-cons (cons new-location (if (directory-pathname-p resource-path) (create-folder-dispatcher-and-handler new-location resource-path) @@ -117,23 +122,87 @@ pages))))) (defmethod lisplet-dispatch-request ((obj lisplet)) - (let ((pages (lisplet-pages obj))) + (let ((pages (lisplet-pages obj))) (loop for dispatcher in pages for action = (funcall (cdr dispatcher) *request*) - when action return (funcall action)))) + when action return (progn + ;; handle authentication + (funcall action))))) (defmethod lisplet-dispatch-method ((obj lisplet)) - (let ((page404 (lisplet-page404 obj)) - (result nil) + (let ((result nil) (base-path (build-lisplet-location obj nil)) (uri (request-uri)) (welcome-page (lisplet-welcome-page obj))) - (if (and welcome-page (string= uri base-path)) - (progn - (redirect (lisplet-welcome-page obj)) - t) - (progn - (setf result (lisplet-dispatch-request obj)) - (when (null result) - (setf result (with-output-to-string (*standard-output*) (page-render page404)))) - result)))) + (progn + (setf (aux-request-value 'lisplet) obj) + (setf (aux-request-value 'realm) (lisplet-realm obj)) + (lisplet-check-authorization obj) + (when (= (return-code) +http-ok+) + (if (and welcome-page (string= uri base-path)) + (progn + (redirect (lisplet-welcome-page obj)) + t) + (progn + (setf result (lisplet-dispatch-request obj)) + (when (null result) + (setf (return-code) +http-not-found+)) + result)))))) + +(defmethod lisplet-protect ((lisplet lisplet) location roles) + (let ((protected-resources (lisplet-protected-resources lisplet)) + (new-location (build-lisplet-location lisplet location))) + (setf (lisplet-protected-resources lisplet) + (sort-protected-resources (push-location-cons + (cons new-location roles) + protected-resources))))) + +(defun redirect-to-https (server request) + (cond + ((= (server-port request) (clawserver-port server)) + (progn + (redirect (request-uri request) + :port (clawserver-sslport server) + :protocol :HTTPS) + (throw 'handler-done nil))) + ((= (server-port request) *apache-http-port*) + (progn + (redirect (request-uri request) + :port *apache-https-port* + :protocol :HTTPS) + (throw 'handler-done nil))))) + +(defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*)) + (let ((uri (request-uri request)) + (protected-resources (lisplet-protected-resources lisplet)) + (princp (current-principal)) + (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 + for match = (format nil "^~a" (car protected-resource)) + for allowed-roles = (cdr protected-resource) + do (when (cl-ppcre:all-matches match uri) + (when (lisplet-redirect-protected-resources-p lisplet) + (redirect-to-https server request)) + (if (null princp) + (progn + (when auth-basicp + (setf (header-out "WWW-Authenticate") + (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)) + (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 05:27:29 2008 @@ -29,7 +29,9 @@ (in-package :claw) - +(defvar *apache-http-port* 80) +(defvar *apache-https-port* 443) + (defun strings-to-jsarray (strings) "Transforms a list of strings into a javascript array." (let ((st-size (length strings)) @@ -50,14 +52,43 @@ (sort dispatchers #'(lambda (item1 item2) (string-not-lessp (car item1) (car item2))))) -(defun remove-dispatcher-by-location (location dispatchers) - "Removes a dispatcher cons (location.dispatcher-method) checking its car +(defun sort-protected-resources (protected-resources) + "Sorts a list of protected resources. A protected resource is a cons where the car is the url +of the resource and the cdr is a list of roles allowhed to access that resource." + (sort protected-resources #'(lambda (item1 item2) + (string-lessp (car item1) (car item2))))) + +(defun remove-by-location (location cons-list) + "Removes a cons checking its car against the location parameter" - (delete-if #'(lambda (dispatcher) (string= (car dispatcher) location)) dispatchers)) + (delete-if #'(lambda (item) (string= (car item) location)) cons-list)) -(defun push-dispatcher (dispatcher dispatchers) - "Isert a new dispatcher into dispatchers, or replace the one that has the same location +(defun push-location-cons (location-cons cons-list) + "Isert a new cons into a list of cons, or replace the one that has the same location registered (its car)." - (let ((result (remove-dispatcher-by-location (car dispatcher) dispatchers))) - (setf result (push dispatcher dispatchers)))) + (let ((result (remove-by-location (car location-cons) cons-list))) + (setf result (push location-cons cons-list)))) +(defun current-realm (&optional (request *request*)) + (aux-request-value 'realm request)) + +(defun current-lisplet (&optional (request *request*)) + (aux-request-value 'lisplet request)) + +(defun current-server (&optional (request *request*)) + (aux-request-value 'clawserver request)) + +(defun current-principal (&optional (session *session*)) + (when session + (session-value 'principal))) + +(defun user-in-rolep (roles &optional (session *session*)) + (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)))) + +(defun login (&optional (request *request*)) + (configuration-login (current-config request))) \ 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 Fri Feb 15 05:27:29 2008 @@ -43,6 +43,8 @@ :*default-encoding* :*rewind-parameter* :*clawserver-base-path* + :*apache-http-port* + :*apache-https-port* ;:request-realm :request-id-table-map ;:dyna-id @@ -225,6 +227,10 @@ :lisplet-register-page-location :lisplet-register-function-location :lisplet-register-resource-location + :lisplet-protect + :lisplet-authentication-type + :lisplet-start-session + :lisplet-redirect-protected-resources-p ;; clawserver :clawserver :clawserver-register-lisplet @@ -241,8 +247,23 @@ :clawserver-input-chunking-p :clawserver-read-timeout :clawserver-write-timeout + :clawserver-login-config + :login #+(and :unix (not :win32)) :clawserver-setuid #+(and :unix (not :win32)) :clawserver-setgid #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file - #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password)) + #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password + :clawserver-register-configuration + :claw-require-authorization + :configuration + :configuration-login + :principal + :current-principal + :principal-name + :principal-roles + :current-lisplet + :current-server + :current-realm + :user-in-rolep + :login)) Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Fri Feb 15 05:27:29 2008 @@ -62,11 +62,25 @@ #-: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 configuration-login (configuration &optional request)) -(defclass page404 (page) - ((style :initform - " +(define-condition http-forbidden-error (error) ()) +(define-condition http-authorization-required-error (error) ()) + +(defclass error-page (page) + ((title :initarg :title + :reader page-title) + (error-code :initarg :error-code + :reader page-error-code)) + (:documentation "This is the template page class used to render +the http error messages.")) + +(defcomponent error-page-template () ()) +(defmethod wcomponent-parameters ((error-page-template error-page-template)) + (list :title :required :error-code :required :style + " body { font-family: arial, elvetica; font-size: 7pt; @@ -85,39 +99,43 @@ margin: 0; margin-bottom: .5em; } -p.h2 {font-size: 1.5em;}" - :reader page404-style)) - (:documentation "This page class is used to render -the 404 (page not found) messages.")) - -(defmethod page-content ((obj page404)) - (html> - (head> - (title> - "404 Page not found") - (style> - (page404-style obj))) - (body> - (p> - (p> :class "h1" - (format nil "HTTP Status 404 - ~a" (request-uri *request*))) - (hr> :noshade "noshade") - (p> - (span> :class "blue" - ($> "type")) - "Status report") - (p> - (span> :class "blue" - "message") - (request-uri *request*)) - (p> - (span> :class "blue" - "description") - (format nil "The requested resource (~a) is not available." (request-uri *request*))) - (hr> :noshade "noshade")) - (p> :class "h2" - "cl-webobject server")))) +p.h2 {font-size: 1.5em;}")) +(defmethod wcomponent-template ((error-page-template error-page-template)) + (let ((error-code (wcomponent-parameter-value error-page-template ':error-code)) + (title (wcomponent-parameter-value error-page-template ':title)) + (style (wcomponent-parameter-value error-page-template ':style))) + (html> + (head> + (title> title) + (style> style)) + (body> + (p> + (p> :class "h1" + (format nil "HTTP Status ~a - ~a" error-code (request-uri *request*))) + (hr> :noshade "noshade") + (p> + (span> :class "blue" + ($> "type")) + "Status report") + (p> + (span> :class "blue" + "url") + (request-uri *request*)) + (p> + (span> :class "blue" + "description") + (gethash error-code hunchentoot::*http-reason-phrase-map*) + ;(htcomponent-body error-page-template) + (hr> :noshade "noshade")) + (p> :class "h2" + "claw server")))))) + +(defmethod page-content ((error-page error-page)) + (error-page-template> :title (page-title error-page) + :error-code (page-error-code error-page) + (format nil "The requested resource (~a) is not available." (request-uri *request*)))) + (defclass clawserver () ((port :initarg :port :reader clawserver-port) @@ -130,7 +148,7 @@ (sslname :initarg :sslname :reader clawserver-sslname) (mod-lisp-p :initarg :mod-lisp-p - :reader clawserver-mod-lisp-p) + :reader clawserver-mod-lisp-p) (use-apache-log-p :initarg :use-apache-log-p :reader clawserver-use-apache-log-p) (input-chunking-p :initarg :input-chunking-p @@ -139,6 +157,11 @@ :reader clawserver-read-timeout) (write-timeout :initarg :write-timeout :reader clawserver-write-timeout) + (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 +succeeds.") #+(and :unix (not :win32)) (setuid :initarg :setuid :reader clawserver-setuid) #+(and :unix (not :win32)) (setgid :initarg :setgid @@ -154,26 +177,40 @@ (sslserver :initform nil :accessor clawserver-sslserver) (lisplets :initform nil - :accessor clawserver-lisplets) - (page404 :initarg :page404 - :accessor clawserver-page404)) + :accessor clawserver-lisplets)) (:default-initargs :address nil :name (gensym) :sslname (gensym) :port 80 :sslport 443 - :mod-lisp-p nil + :mod-lisp-p nil :input-chunking-p t :read-timeout *default-read-timeout* :write-timeout *default-write-timeout* #+(and :unix (not :win32)) :setuid nil #+(and :unix (not :win32)) :setgid nil #-:hunchentoot-no-ssl :ssl-certificate-file nil - #-:hunchentoot-no-ssl :ssl-privatekey-password nil - :page404 (make-instance 'page404)) + #-:hunchentoot-no-ssl :ssl-privatekey-password nil) (:documentation "CLAWSERVER is built around huncentoot and has the instructions for lisplet dispatching, so use this class to start and stop -hunchentoot server.")) +3hunchentoot server.")) + +(defclass configuration () + () + (:documentation "A configuration class for CLAW server realm login configurations")) + +(defmethod configuration-login ((configuration configuration) &optional (request *request*)) + (declare (ignore request))) + +(defclass principal () + ((name :initarg :name + :reader principal-name + :documentation "The principal username who is logged into the application") + (roles :initarg :roles + :accessor principal-roles + :documentation "The roles where that owns the user logged into the application")) + (: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) (let ((use-apache-log-p (getf keys :use-apache-log-p :undefined)) @@ -189,7 +226,7 @@ (location (lisplet-base-path lisplet-obj))) (unless (null server-base-path) (setf location (format nil "~@[~a~]~a" server-base-path location))) - (setf (clawserver-lisplets obj) (sort-dispatchers (push-dispatcher + (setf (clawserver-lisplets obj) (sort-dispatchers (push-location-cons (cons location (create-prefix-dispatcher location @@ -204,7 +241,7 @@ (location (lisplet-base-path lisplet-obj))) (unless (null server-base-path) (setf location (format nil "~@[~a~]~a" server-base-path location))) - (remove-dispatcher-by-location location lisplets))) + (remove-by-location location lisplets))) ;;;-------------------------- WRITERS ---------------------------------------- @@ -285,6 +322,9 @@ (setf (slot-value obj 'ssl-privatekey-password) val)) ;;;-------------------------- 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))) (loop for dispatcher in lisplets @@ -292,12 +332,13 @@ when action return (funcall action)))) (defmethod clawserver-dispatch-method ((obj clawserver)) - (let ((page404 (clawserver-page404 obj)) - (result nil)) + (let ((result nil)) (progn + (setf (aux-request-value 'clawserver) obj) (setf result (clawserver-dispatch-request obj)) (if (null result) - #'(lambda () (with-output-to-string (*standard-output*) (page-render page404))) + #'(lambda () (when (= (return-code) +http-ok+) + (setf (return-code *reply*) +http-not-found+))) #'(lambda () result))))) (defmethod clawserver-start ((obj clawserver)) @@ -355,6 +396,13 @@ (when (clawserver-sslserver obj) (setf (clawserver-sslserver obj) (stop-server (clawserver-sslserver obj)))))) ;;;---------------------------------------------------------------------------- +(defun login (&optional (request *request*)) + (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 &key (port 80) address @@ -385,5 +433,30 @@ #-:hunchentoot-no-ssl :ssl-certificate-file ssl-certificate-file #-:hunchentoot-no-ssl :ssl-privatekey-file ssl-privatekey-file #-:hunchentoot-no-ssl :ssl-privatekey-password ssl-privatekey-password)) - - \ No newline at end of file + +#| + (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 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 05:27:29 2008 @@ -273,7 +273,7 @@ (result)) (if (= 0 client-id-index) (setf result id) - (setf result (format nil "~a~d" id client-id-index))) + (setf result (format nil "~a_~d" id client-id-index))) (setf (gethash id id-ht) (1+ client-id-index)) result)) @@ -288,7 +288,7 @@ (id (getf (first fbody) :id)) (static-id (getf (first fbody) :static-id)) (instance)) - (unless (null static-id) + (when static-id (remf (first fbody) :id) (setf id nil)) (setf instance (make-instance parent @@ -297,7 +297,7 @@ :attributes (first fbody) :body (second fbody))) (if (null static-id) - (unless (or (null id-table-map) (null id)) + (when (and id-table-map id) (setf (htcomponent-client-id instance) (generate-id id))) (setf (htcomponent-client-id instance) static-id)) @@ -486,14 +486,13 @@ (defmethod (setf htcomponent-page) ((pobj page) (obj htcomponent)) (let ((id (getf (htcomponent-attributes obj) :id)) - (static-id (getf (htcomponent-attributes obj) :static-id))) + (static-id (getf (htcomponent-attributes obj) :static-id)) + (client-id (htcomponent-client-id obj))) (setf (slot-value obj 'page) pobj) - (unless (and (null id) (null static-id)) - (let ((client-id (htcomponent-client-id obj))) - (when (null client-id) - (if (null static-id) - (setf (htcomponent-client-id obj) (generate-id id)) - (setf (htcomponent-client-id obj) static-id))))))) + (unless client-id + (if static-id + (setf (htcomponent-client-id obj) static-id) + (setf (htcomponent-client-id obj) (generate-id id)))))) (defmethod page-request-parameters ((pobj page)) (if (and (boundp '*request*) (null (slot-value pobj 'request-parameters))) @@ -509,7 +508,7 @@ (defmethod page-req-parameter ((pobj page) name &optional as-list) (let ((parameters (page-request-parameters pobj)) (retval)) - (unless (null parameters) + (when parameters (setf retval (gethash (string-upcase name) parameters)) (if (or (null retval) as-list) retval @@ -551,28 +550,30 @@ (xml-p (page-xmloutput obj)) (content-type (page-doc-type obj))) (when (null json-p) - (unless (null xml-p) + (when xml-p (page-format-raw obj "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) - (unless (null content-type) + (when content-type (page-format-raw obj "~a~%" content-type))))) -(defmethod page-render ((obj page)) +(defmethod page-render ((obj page)) (let ((body (page-content obj)) (json-p (page-json-id-list obj))) (if (null body) (format nil "null body for page ~a~%" (type-of obj)) (progn (page-init obj) - (unless (null (page-req-parameter obj *rewind-parameter*)) + (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) - (unless (null json-p) + (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!!! - (unless (null json-p) + (when json-p (page-format-raw obj "},classInjections:\"") (setf (page-can-print obj) t) (dolist (injection (page-init-injections obj)) @@ -640,7 +641,8 @@ (let* ((pobj (htcomponent-page obj)) (json-p (page-json-id-list pobj)) (id (htcomponent-client-id obj))) - (unless (or (null json-p) (null (member id json-p :test #'string-equal))) + (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) @@ -650,7 +652,8 @@ (let* ((pobj (htcomponent-page obj)) (json-p (page-json-id-list pobj)) (id (htcomponent-client-id obj))) - (unless (or (null json-p) (null (member id json-p :test #'string-equal))) + (when (or json-p + (member id json-p :test #'string-equal)) (page-format-raw pobj "\"")))) (defmethod htcomponent-rewind :before ((obj htcomponent) (pobj page)) @@ -667,6 +670,7 @@ (defmethod htcomponent-prerender ((obj htcomponent) (pobj page)) (let ((previous-print-status (page-can-print pobj))) +; (log-message :info "------------------- ~a" previous-print-status) (when (null previous-print-status) (setf (page-can-print pobj) (htcomponent-can-print obj))) (dolist (tag (htcomponent-body obj)) @@ -677,7 +681,7 @@ (defmethod htcomponent-render ((obj htcomponent) (pobj page)) (let ((body-list (htcomponent-body obj)) - (previous-print-status (page-can-print pobj))) + (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)) @@ -691,11 +695,11 @@ ;;;========= TAG ===================================== (defmethod tag-render-attributes ((obj tag) (pobj page)) - (unless (null (htcomponent-attributes obj)) + (when (htcomponent-attributes obj) (loop for (k v) on (htcomponent-attributes obj) by #'cddr do (progn (assert (keywordp k)) - (unless (null v) + (when v (page-format pobj " ~a=\"~a\"" (string-downcase (if (eq k :static-id) "id" @@ -744,15 +748,15 @@ (when (null previous-print-status) (setf (page-can-print pobj) (htcomponent-can-print obj)) (htcomponent-json-print-start-component obj)) - (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (when (or (page-can-print pobj) previous-print-status) (tag-render-starttag obj pobj)) (dolist (tag body-list) (if (stringp tag) (htcomponent-render ($> tag) pobj) (htcomponent-render tag pobj))) - (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (when (or (page-can-print pobj) previous-print-status) (tag-render-endtag obj pobj)) - (when (null previous-print-status) + (unless previous-print-status (setf (page-can-print pobj) nil) (htcomponent-json-print-end-component obj)))) @@ -779,8 +783,8 @@ (let ((body (htcomponent-body obj)) (json-p (not (null (page-json-id-list pobj)))) (print-p (page-can-print pobj))) - (unless (or (null print-p) (null body)) - (unless (null json-p) + (when (or print-p body) + (when json-p (setf body (regex-replace-all "\"" (regex-replace-all "\\\\\"" (regex-replace-all "\\n" @@ -788,14 +792,14 @@ "\\n") "\\\\\\\"") "\\\""))) - (if (null (htstring-raw obj)) + (if (htstring-raw obj) + (page-format-raw pobj 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 pobj body))))) + (t (page-format-raw pobj "~a" ch)))))))) ;;;========= HTSCRIPT =================================== (defmethod htcomponent-prerender((obj htscript) (pobj page))) @@ -809,7 +813,7 @@ (htcomponent-json-print-start-component obj)) (unless (getf (htcomponent-attributes obj) :type) (append '(:type "text/javascript") (htcomponent-attributes obj))) - (unless (null (page-can-print pobj)) + (when (page-can-print pobj) (tag-render-starttag obj pobj) (when (and (null (getf (htcomponent-attributes obj) :src)) (not (null (htcomponent-body obj)))) @@ -838,7 +842,7 @@ (when (null previous-print-status) (setf (page-can-print pobj) (htcomponent-can-print obj)) (htcomponent-json-print-start-component obj)) - (unless (null (page-can-print pobj)) + (when (page-can-print pobj) (unless (getf (htcomponent-attributes obj) :type) (append '(:type "text/css") (htcomponent-attributes obj))) (unless (getf (htcomponent-attributes obj) :rel) @@ -853,19 +857,19 @@ (defmethod htcomponent-render ((obj htbody) (pobj page)) (let ((body-list (htcomponent-body obj)) (previous-print-status (page-can-print pobj))) - (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (when (or (page-can-print pobj) previous-print-status) (setf (page-can-print pobj) (htcomponent-can-print obj)) (htcomponent-json-print-start-component obj)) - (unless (null (page-can-print pobj)) + (when (page-can-print pobj) (tag-render-starttag obj pobj)) (dolist (tag body-list) (if (stringp tag) (htcomponent-render ($> tag) pobj) (htcomponent-render tag pobj))) - (unless (null (page-can-print pobj)) + (when (page-can-print pobj) (htcomponent-render (htbody-init-scripts-tag pobj) pobj) (tag-render-endtag obj pobj)) - (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (when (or (page-can-print pobj) previous-print-status) (setf (page-can-print pobj) nil) (htcomponent-json-print-end-component obj)))) @@ -920,7 +924,7 @@ (defun make-component (name parameters content) (let ((instance (make-instance name)) (static-id (getf parameters :static-id))) - (unless (null static-id) + (when static-id (remf parameters :id)) (loop for (k v) on parameters by #'cddr do (let ((keyword k)) @@ -929,7 +933,7 @@ (multiple-value-bind (inst-k inst-v inst-p) (get-properties (wcomponent-parameters instance) (list keyword)) (declare (ignore inst-v)) - (unless (null (find inst-k (wcomponent-reserved-parameters instance))) + (when (find inst-k (wcomponent-reserved-parameters instance)) (error (format nil "Parameter ~a is reserved" inst-k))) (if (null inst-p) (if (null (wcomponent-allow-informal-parametersp instance)) @@ -999,14 +1003,14 @@ (template (wcomponent-template obj))) (when (null previous-print-status) (setf (page-can-print pobj) (htcomponent-can-print obj))) - (unless (null (page-can-print pobj)) + (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)) - (unless (null (htcomponent-instance-initscript obj)) + (when (htcomponent-instance-initscript obj) (pushnew (htcomponent-instance-initscript obj) (page-instance-initscripts pobj) :test #'equal))) (if (listp template) (dolist (tag template) Added: trunk/main/claw-core/tests/img/matrix.jpg ============================================================================== Binary file. No diff available. 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 05:27:29 2008 @@ -29,6 +29,7 @@ (in-package :claw-tests) +(setf *rewrite-for-session-urls* nil) (defvar *this-file* (load-time-value (or #.*compile-file-pathname* *load-pathname*))) @@ -42,14 +43,42 @@ -(defparameter *clawserver* (make-instance 'clawserver :port 4242)) -;;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 -;;; :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" -;;; :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) +;;;(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*) (clawserver-register-lisplet *clawserver* *test-lisplet2*) +(defun test-configuration-do-login (request user password) + (let ((session *session*)) + (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"))))))) + + + +(defclass test-configuration (configuration) ()) + +(defmethod configuration-login ((test-configuration test-configuration) &optional (request *request*)) + (let ((lisplet (current-lisplet request))) + (multiple-value-bind (user password) + (if (eq (lisplet-authentication-type lisplet) :basic) + (authorization) + (values (aux-request-value 'user request) + (aux-request-value 'password request))) + (test-configuration-do-login request user password)))) + +(clawserver-register-configuration *clawserver* "test1" (make-instance 'test-configuration)) + + + (defun claw-tst-start () (clawserver-start *clawserver*)) @@ -71,18 +100,29 @@ (wcomponent-parameter-value o ':title))) (body> (wcomponent-informal-parameters o) - (p> - (a> :href "/claw/test/index.html")) + (div> + :style "background-color: #DBDFE0;padding: 3px;" + (a> :href "/claw/test/index.html" "home")) (htcomponent-body o)))) ;;;--------------------index testing page-------------------------------- +(defclass auth-page (page) ()) +(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")) + (defclass index-page (page) ()) (defmethod page-content ((o index-page)) (site-template> :title "Home test page" (p> :id "p" (ul> + (li> (a> :href "login.html" + "Do login")) (li> (a> :href "images/matrix.jpg" "show static file")) (li> (a> :href "images/matrix2.jpg" @@ -92,11 +132,12 @@ (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) (li> (a> :href "id-tests.html" "id generation test")) - (li> (a> :href "form.html" ($> "form components test"))))))) + (li> (a> :href "form.html" "form components test")) + (li> (a> :href "unauth.html" "unauthorized page")))))) (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" t) +(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-pagep t) (lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg") @@ -119,7 +160,7 @@ (let ((lisplet (page-lisplet o))) (when (or (null *session*) (not (string= (session-realm *session*) (lisplet-realm lisplet)))) (progn - (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (page-lisplet o)))) + (lisplet-start-session) (setf (session-value 'RND-NUMBER) (random 1000)))) (site-template> :title "Realm test page" (p> @@ -153,21 +194,67 @@ (hr>) (div> :id "foo" :class "goo" :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") (div> :id "foo" :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") (div> :static-id uid :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]") (div> :static-id uid2 :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")))) (lisplet-register-page-location *test-lisplet* 'id-tests-page "id-tests.html") ;;;--------------------from components testing page-------------------------------- + +(defgeneric login-page-login (login-page)) + +(defclass login-page (page) + ((username :initform "" + :accessor login-page-username) + (passowrd :initform "" + :accessor login-page-password))) + +(defmethod page-content ((login-page login-page)) + (let ((princp (current-principal))) + (site-template> :title "a page title" + (if (null princp) + (cform> :id "loginform" :method "post" :action 'login-page-login + (table> + (tr> + (td> "Username") + (td> + (cinput> :id "username" + :type "text" + :accessor 'login-page-username))) + (tr> + (td> "Password") + (td> + (cinput> :id "passowrd" + :type "password" + :accessor 'login-page-password))) + (tr> + (td> :colspan "2" + (csubmit> :id "submit" :value "Login"))))) + (p> + "Welcome " + (principal-name princp) + (a> :href "index.html" "home")))))) + +(defmethod login-page-login ((login-page login-page)) + (setf (aux-request-value 'user) (login-page-username login-page) + (aux-request-value 'password) (login-page-password login-page)) + (login)) + +(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-pagep t) + (defclass form-page (page) ((name :initarg :name :accessor form-page-name)

1 0