Author: achiumenti Date: Tue May 13 09:32:43 2008 New Revision: 46 Modified: trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/tests/test1.lisp Log: corrected 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 Tue May 13 09:32:43 2008 @@ -99,42 +99,42 @@ (setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) - (let* ((error-handlers (if (current-lisplet) - (lisplet-error-handlers (current-lisplet)) - (make-hash-table))) - (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))))))) + (let* ((error-handlers (if (current-lisplet) + (lisplet-error-handlers (current-lisplet)) + (make-hash-table))) + (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))))))) (defclass lisplet (i18n-aware) ((base-path :initarg :base-path - :reader lisplet-base-path - :documentation "common base path all resources registered into this lisplet") + :reader lisplet-base-path + :documentation "common base path all resources registered into this lisplet") (welcome-page :initarg :welcome-page - :accessor lisplet-welcome-page - :documentation "url location for the welcome page") + :accessor lisplet-welcome-page + :documentation "url location for the welcome page") (login-page :initarg :login-page - :accessor lisplet-login-page - :documentation "url location for the welcome page") + :accessor lisplet-login-page + :documentation "url location for the welcome page") (realm :initarg :realm - :reader lisplet-realm - :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") + :reader lisplet-realm + :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") (pages :initform nil - :accessor lisplet-pages - :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher") + :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-handlers - :documentation "An hash table where keys are http error codes and values are functions with no parameters") + :accessor lisplet-error-handlers + :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 - :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") + :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 - :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")) + :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" @@ -144,19 +144,19 @@ (defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) - (location (lisplet-base-path lisplet))) + (location (lisplet-base-path lisplet))) (setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location - (cons location - #'(lambda () - (progn - (setf (current-realm *request*) (lisplet-realm lisplet) - (current-lisplet) lisplet) - (lisplet-dispatch-method lisplet)))) - dispatchers))))) + (cons location + #'(lambda () + (progn + (setf (current-realm *request*) (lisplet-realm lisplet) + (current-lisplet) lisplet) + (lisplet-dispatch-method lisplet)))) + dispatchers))))) (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) - (location (lisplet-base-path lisplet))) + (location (lisplet-base-path lisplet))) (remove-by-location location dispatchers))) @@ -172,7 +172,7 @@ (defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) - (sort-by-location (pushnew-location (cons location function) pages))) + (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p (setf (lisplet-welcome-page lisplet) location)) (when login-page-p @@ -180,102 +180,100 @@ (defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p) (lisplet-register-function-location lisplet - #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url location)))) - location - :welcome-page-p welcome-page-p - :login-page-p login-page-p)) + #'(lambda () (with-output-to-string (*standard-output*) + (page-render (make-instance page-class :lisplet lisplet :url location)))) + location + :welcome-page-p welcome-page-p + :login-page-p login-page-p)) (defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type) (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) - (sort-by-location (pushnew-location - (cons location - (if (directory-pathname-p resource-path) - #'(lambda () - (let ((resource-full-path (merge-pathnames - (uri-to-pathname (subseq (script-name) - (+ (length (clawserver-base-path (current-server))) - (length (lisplet-base-path (lisplet-base-path lisplet)))))) - resource-path))) - (handle-static-file resource-full-path content-type))) - #'(lambda () (handle-static-file resource-path content-type)))) - pages))))) + (sort-by-location (pushnew-location + (cons location + (if (directory-pathname-p resource-path) + #'(lambda () + (let ((resource-full-path (merge-pathnames + (uri-to-pathname (subseq (script-name) + (+ (length (clawserver-base-path (current-server))) + (length (lisplet-base-path (lisplet-base-path lisplet)))))) + resource-path))) + (handle-static-file resource-full-path content-type))) + #'(lambda () (handle-static-file resource-path content-type)))) + pages))))) (defmethod lisplet-dispatch-request ((lisplet lisplet)) (let ((dispatchers (lisplet-pages lisplet)) - (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet)))))) + (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet)))))) (loop for dispatcher in dispatchers - for url = (car dispatcher) - for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))))) + for url = (car dispatcher) + for action = (cdr dispatcher) + do (cond + ((and (string< url rel-script-name) + (null (starts-with-subseq rel-script-name url))) (return nil)) + ((starts-with-subseq rel-script-name url) (return (funcall action))))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) - (uri (script-name)) - (welcome-page (lisplet-welcome-page lisplet))) + (uri (script-name)) + (welcome-page (lisplet-welcome-page lisplet))) (lisplet-check-authorization lisplet) - (when (= (return-code) +http-ok+) - (if (and welcome-page (string= uri base-path)) - (page-render (lisplet-welcome-page lisplet)) - (lisplet-dispatch-request lisplet))))) + (when (= (return-code) +http-ok+) + (if (and welcome-page (string= uri base-path)) + (page-render (lisplet-welcome-page lisplet)) + (lisplet-dispatch-request lisplet))))) (defmethod lisplet-protect ((lisplet lisplet) location roles) (let ((protected-resources (lisplet-protected-resources lisplet))) (setf (lisplet-protected-resources lisplet) - (sort-protected-resources (pushnew-location - (cons location roles) - protected-resources))))) - -(defun redirect-to-https (server request) - "Redirects a request sent through http using https" - (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))))) + (sort-protected-resources (pushnew-location + (cons location roles) + protected-resources))))) + +(defun redirect-to-https (server request &optional uri) + "Redirects a request sent through http using https" + (let ((path (or uri (request-uri request))) + (port (server-port request)) + (protocol :http)) + #-:hunchentoot-no-ssl (when (or (clawserver-mod-lisp-p server) + (clawserver-ssl-certificate-file server)) + (setf protocol :https + port (if (clawserver-mod-lisp-p server) + *apache-https-port* + (clawserver-sslport server)))) + (redirect path :port port :protocol protocol))) (defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*)) - (let ((uri (script-name request)) - (base-path (build-lisplet-location lisplet)) - (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))) + (let* ((uri (script-name request)) + (base-path (build-lisplet-location lisplet)) + (protected-resources (lisplet-protected-resources lisplet)) + (princp (current-principal)) + (login-config (current-config)) + (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet))) + (server (current-server request)) + (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)) + (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~a" base-path (car protected-resource)) - for allowed-roles = (cdr protected-resource) - do (when (starts-with-subseq 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 (user-in-role-p allowed-roles) - (setf (return-code) +http-forbidden+) - (throw 'handler-done nil)))))))) + for match = (format nil "~a/~a" base-path (car protected-resource)) + for allowed-roles = (cdr protected-resource) + do (when (or (starts-with-subseq match uri) (string= login-page-url uri)) + ;(when (lisplet-redirect-protected-resources-p lisplet) + ;(redirect-to-https server request)) + (cond + ((and (null princp) auth-basicp) + (setf (return-code) +http-authorization-required+ + (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))) + (throw 'handler-done nil)) + ((and (null princp) (null auth-basicp) (not (string= login-page-url uri))) + (redirect-to-https server request login-page-url) + (throw 'handler-done nil)) + ((and (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) + (setf (return-code) +http-forbidden+) + (throw 'handler-done nil)) + #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*))) + (redirect-to-https server request) + (throw 'handler-done nil)))))))) Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Tue May 13 09:32:43 2008 @@ -379,18 +379,20 @@ (let ((base-path (clawserver-base-path clawserver)) (dispatchers (clawserver-dispatchers clawserver)) (script-name (script-name)) - (rel-script-name)) + (rel-script-name) + (rel-script-name-libs)) (setf (current-server) clawserver) (when (starts-with-subseq script-name base-path) - (setf rel-script-name (subseq script-name (length base-path))) + (setf rel-script-name (subseq script-name (length base-path)) + rel-script-name-libs (subseq script-name (1+ (length base-path)))) (or (loop for dispatcher in *claw-libraries-resources* for url = (car dispatcher) for action = (cdr dispatcher) do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))) + ((and (string< url rel-script-name-libs) + (null (starts-with-subseq rel-script-name-libs url))) (return nil)) + ((starts-with-subseq rel-script-name-libs url) (return (funcall action))))) (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Tue May 13 09:32:43 2008 @@ -37,8 +37,8 @@ (or #.*compile-file-pathname* *load-pathname*))) -(register-library-resource "/libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img")))) -(register-library-resource "/libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) +(register-library-resource "libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img")))) +(register-library-resource "libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) (defvar *lisplet-messages* (make-instance 'simple-message-dispatcher)) @@ -55,23 +55,23 @@ (defvar *test-lisplet*) (setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" - :redirect-protected-resources-p t)) + :redirect-protected-resources-p t)) (defvar *test-lisplet2*) (setf *test-lisplet2* (make-instance 'lisplet :realm "test2" - :base-path "/test2")) + :base-path "/test2")) ;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw")) (defvar *clawserver* (make-instance 'clawserver - :port 4242 - :sslport 4445 - :base-path "/claw" - :mod-lisp-p nil - :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" - :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) + :port 4242 + :sslport 4445 + :base-path "/claw" + :mod-lisp-p nil + :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) + ;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) (clawserver-register-lisplet *clawserver* *test-lisplet*) (clawserver-register-lisplet *clawserver* *test-lisplet2*) @@ -80,7 +80,7 @@ (declare (ignore request)) (let ((session *session*)) (when (and (string-equal user "kiuma") - (string-equal password "password")) + (string-equal password "password")) (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))) @@ -90,14 +90,14 @@ (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))) + (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 () @@ -111,7 +111,7 @@ (defclass site-template (wcomponent) ((title :initarg :title - :reader title)) + :reader title)) (:metaclass metacomponent)) (defmethod wcomponent-template ((o site-template)) @@ -120,7 +120,7 @@ (title> (title o)) (style> :type "text/css" -"input.error { + "input.error { background-color: #FF9999; } ")) @@ -136,37 +136,41 @@ (defclass auth-page (page) ()) (defmethod page-content ((page auth-page)) (site-template> :title "Unauth test page" - (p> "protected content"))) -(lisplet-register-page-location *test-lisplet* 'auth-page "/unauth.html") -(lisplet-register-page-location *test-lisplet* 'auth-page "/auth.html") -(lisplet-protect *test-lisplet* "/auth.html" '("admin" "user")) -(lisplet-protect *test-lisplet* "/unauth.html" '("nobody")) + (p> "protected content"))) +(lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html") +(lisplet-register-page-location *test-lisplet* 'auth-page "auth.html") +(lisplet-protect *test-lisplet* "auth.html" '("admin" "user")) +(lisplet-protect *test-lisplet* "unauth.html" '("nobody")) (defclass index-page (page) ()) -(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 "info.html" - "Headers info")) - (li> (a> :href (format nil "~a/libs/images/matrix.jpg" (clawserver-base-path (current-server))) - "show static file provided by CLAW-TESTS package")) - (li> (a> :href "images/matrix.jpg" - "show static file")) - (li> (a> :href "images/matrix2.jpg" - "show file by function")) - (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> (a> :href "id-tests.html" "id generation test")) - (li> (a> :href "form.html" "form components test")) - (li> (a> :href "auth.html" "authorized page")) - (li> (a> :href "unauth.html" "unauthorized page")))))) -(lisplet-register-page-location *test-lisplet* 'index-page "/index.html" :welcome-page-p t) +(defmethod page-content ((o index-page)) + (let ((clawserver-base-path (clawserver-base-path (current-server)))) + (site-template> :title "Home test page" + (p> :id "p" + (ul> + (li> (a> :href "login.html" + "Do login")) + (li> (a> :href "info.html" + "Headers info")) + (li> (a> :href (format nil "~a/libs/images/matrix.jpg" clawserver-base-path) + "show static file provided by CLAW-TESTS package by folder")) + (li> (a> :href (format nil "~a/libs/img.jpg" clawserver-base-path) + "show static file provided by CLAW-TESTS package by file")) + (li> (a> :href "images/matrix.jpg" + "show static file")) + (li> (a> :href "images/matrix2.jpg" + "show file by function")) + (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> (a> :href "id-tests.html" "id generation test")) + (li> (a> :href "form.html" "form components test")) + (li> (a> :href "auth.html" "authorized page")) + (li> (a> :href "unauth.html" "unauthorized page"))))))) + +(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t) (defclass msie-p (wcomponent) () @@ -179,43 +183,43 @@ (defmethod htcomponent-instance-initscript ((msie-p msie-p)) (let ((id (htcomponent-client-id msie-p))) (format nil "document.getElementById('~a').innerHTML = '~a';" - id - (if (msie-p) - "The browser is MSIE" - "The browser is not MSIE")))) + id + (if (msie-p) + "The browser is MSIE" + "The browser is not MSIE")))) (defclass info-page (page) ()) (defmethod page-content ((o info-page)) (let ((header-props (headers-in))) (site-template> :title "Header info page" - (p> :id "p" - (table> - (tr> (td> :colspan "2" "Header info")) - (loop for key-val in header-props - collect (tr> - (td> (format nil "~a" (car key-val)) - (td> (format nil "~a" (cdr key-val)))))))) - (msie-p> :id "msie")))) + (p> :id "p" + (table> + (tr> (td> :colspan "2" "Header info")) + (loop for key-val in header-props + collect (tr> + (td> (format nil "~a" (car key-val)) + (td> (format nil "~a" (cdr key-val)))))))) + (msie-p> :id "msie")))) -(lisplet-register-page-location *test-lisplet* 'info-page "/info.html") +(lisplet-register-page-location *test-lisplet* 'info-page "info.html") (defun test-image-file () (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) -(lisplet-register-resource-location *test-lisplet* (test-image-file) "/images/matrix.jpg" "image/jpeg") +(lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg") (lisplet-register-function-location *test-lisplet* - (lambda () - (let ((path (test-image-file))) - (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) - (with-open-file (in path :element-type 'flex:octet) - (let ((image-data (make-array (file-length in) - :element-type 'flex:octet))) - (read-sequence image-data in) - image-data)))) - "/images/matrix2.jpg" ) + (lambda () + (let ((path (test-image-file))) + (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) + (with-open-file (in path :element-type 'flex:octet) + (let ((image-data (make-array (file-length in) + :element-type 'flex:octet))) + (read-sequence image-data in) + image-data)))) + "images/matrix2.jpg" ) ;;;--------------------realm test page-------------------------------- (defclass realm-page (page) ()) @@ -224,54 +228,54 @@ (claw-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: " (current-realm)) - (li> "Session Realm: " (session-realm *session*)) - (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) - (li> "Request Realm: " (hunchentoot::realm *request*)))))) + (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: " (current-realm)) + (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") +(lisplet-register-page-location *test-lisplet* 'realm-page "realm.html") +(lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html") ;;;--------------------id testing page-------------------------------- (defclass id-tests-page (page) ()) (defmethod page-content ((o id-tests-page)) (let ((uid (generate-id "uid")) - (uid2 (generate-id "uid"))) + (uid2 (generate-id "uid"))) (site-template> :title "a page title" - "\"<escaping>test\"" - (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]")))) + "\"<escaping>test\"" + (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") +(lisplet-register-page-location *test-lisplet* 'id-tests-page "id-tests.html") ;;;--------------------from components testing page-------------------------------- @@ -280,77 +284,77 @@ (defclass login-page (page) ((username :initform "" - :accessor login-page-username) + :accessor login-page-username) (passowrd :initform "" - :accessor login-page-password)) + :accessor login-page-password)) (:default-initargs :message-dispatcher *lisplet-messages*)) (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> - (with-message "WELCOME" "WELCOME") " " - (principal-name princp) - (a> :href "index.html" "home")))))) + (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> + (with-message "WELCOME" "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)) + (aux-request-value 'password) (login-page-password login-page)) (login)) -(lisplet-register-page-location *test-lisplet* 'login-page "/login.html" :login-page-p t) +(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) (defclass user () ((name :initarg :name - :accessor user-name) + :accessor user-name) (surname :initarg :surname - :accessor user-surname) - (gender :initarg :gender - :accessor user-gender) + :accessor user-surname) + (gender :initarg :gender + :accessor user-gender) (age :initarg :age - :accessor user-age) + :accessor user-age) (capital :initarg :capital - :accessor user-capital)) + :accessor user-capital)) (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0)) (defgeneric form-page-update-user (form-page)) (defclass form-page (page user) ((name :initarg :name - :accessor form-page-name) + :accessor form-page-name) (surname :initarg :surname - :accessor form-page-surname) + :accessor form-page-surname) (colors :initarg :colors - :accessor form-page-colors) + :accessor form-page-colors) (gender :initarg :gender - :writer setf-gender - :accessor form-page-gender) + :writer setf-gender + :accessor form-page-gender) (user :initarg :user - :accessor form-page-user) + :accessor form-page-user) (age :initarg :age - :accessor form-page-age) + :accessor form-page-age) (capital :initarg :capital - :accessor form-page-capital) + :accessor form-page-capital) (birthday :initarg :birthday - :accessor form-page-birthday)) + :accessor form-page-birthday)) (:default-initargs :name "kiuma" :surname "surnk" @@ -364,118 +368,118 @@ (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 (form-page-gender form-page)) - (age (form-page-age form-page))) + (name (form-page-name form-page)) + (surname (form-page-surname form-page)) + (gender (form-page-gender form-page)) + (age (form-page-age form-page))) (setf (user-name user) name - (user-surname user) surname - (user-gender user) gender - (user-age user) age))) + (user-surname user) surname + (user-gender user) gender + (user-age user) age))) -;(defmethod message-dispatch ((object form-page) key locale) + ;(defmethod message-dispatch ((object form-page) key locale) (defmethod page-content ((o form-page)) (site-template> :title "a page title" - (cform> :id "testform" :method "post" :action #'form-page-update-user - (table> - (tr> - (td> "Name") - (td> - (cinput> :id "name" - :type "text" - :label "Name" - :validator #'(lambda (value) - (validate-required (page-current-component o) value)) - :accessor 'form-page-name)"*")) - (tr> :id "messaged" - (td> (with-message "SURNAME" "SURNAME")) - (td> - (cinput> :id "surname" - :type "text" - :label "Surname" - :validator #'(lambda (value) - (validate-required (page-current-component o) value) - (validate-size (page-current-component o) value :min-size 1 :max-size 20)) - :accessor 'form-page-surname)"*")) - (tr> - (td> "Gender") - (td> - (cselect> :id "gender" - :accessor 'form-page-gender - (loop for gender in (list "M" "F") - collect (option> :value gender - (when (string= gender (form-page-gender o)) - '(:selected "selected")) - (if (string= gender "M") - "Male" - "Female")))))) - (tr> - (td> "Age") - (td> - (cinput> :id "age" - :type "text" - :label "Age" - :translator (make-instance 'translator-integer :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-integer component value :min 1 :max 2000))) - :accessor 'form-page-age)"*")) - (tr> - (td> "Birthday") - (td> - (cinput> :id "bday" - :type "text" - :label "Birthday" - :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) - :accessor 'form-page-birthday)"(dd-mm-yyyy)")) - (tr> - (td> "Capital") - (td> - (cinput> :id "capital" - :type "text" - :label "Capital" - :translator (make-instance 'translator-number - :decimal-digits 2 - :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-number component value :min 1000.01 :max 500099/100))) - :accessor 'form-page-capital)"*")) - (tr> - (td> "Colors") - (td> - (cselect> :id "colors" - :multiple "true" - :style "width:80px;height:120px;" - :accessor 'form-page-colors - (loop for color in (list "R" "G" "B") - collect (option> :value color - (when (find color (form-page-colors o) :test #'string=) - '(:selected "selected")) - (cond - ((string= color "R") "red") - ((string= color "G") "green") - (t "blue"))))))) - (tr> - (td> :colspan "2" - (csubmit> :id "submit" :value "OK"))))) - (p> - (exception-monitor>) - (hr>) - (h2> "From result:") - (div> (format nil "Name: ~a" (user-name (form-page-user o)))) - (div> (format nil "Surname: ~a" (user-surname (form-page-user o)))) - (div> (format nil "Gender: ~a" (user-gender (form-page-user o)))) - (div> (format nil "Age: ~a" (user-age (form-page-user o))))))) + (cform> :id "testform" :method "post" :action #'form-page-update-user + (table> + (tr> + (td> "Name") + (td> + (cinput> :id "name" + :type "text" + :label "Name" + :validator #'(lambda (value) + (validate-required (page-current-component o) value)) + :accessor 'form-page-name)"*")) + (tr> :id "messaged" + (td> (with-message "SURNAME" "SURNAME")) + (td> + (cinput> :id "surname" + :type "text" + :label "Surname" + :validator #'(lambda (value) + (validate-required (page-current-component o) value) + (validate-size (page-current-component o) value :min-size 1 :max-size 20)) + :accessor 'form-page-surname)"*")) + (tr> + (td> "Gender") + (td> + (cselect> :id "gender" + :accessor 'form-page-gender + (loop for gender in (list "M" "F") + collect (option> :value gender + (when (string= gender (form-page-gender o)) + '(:selected "selected")) + (if (string= gender "M") + "Male" + "Female")))))) + (tr> + (td> "Age") + (td> + (cinput> :id "age" + :type "text" + :label "Age" + :translator (make-instance 'translator-integer :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-integer component value :min 1 :max 2000))) + :accessor 'form-page-age)"*")) + (tr> + (td> "Birthday") + (td> + (cinput> :id "bday" + :type "text" + :label "Birthday" + :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) + :accessor 'form-page-birthday)"(dd-mm-yyyy)")) + (tr> + (td> "Capital") + (td> + (cinput> :id "capital" + :type "text" + :label "Capital" + :translator (make-instance 'translator-number + :decimal-digits 2 + :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-number component value :min 1000.01 :max 500099/100))) + :accessor 'form-page-capital)"*")) + (tr> + (td> "Colors") + (td> + (cselect> :id "colors" + :multiple "true" + :style "width:80px;height:120px;" + :accessor 'form-page-colors + (loop for color in (list "R" "G" "B") + collect (option> :value color + (when (find color (form-page-colors o) :test #'string=) + '(:selected "selected")) + (cond + ((string= color "R") "red") + ((string= color "G") "green") + (t "blue"))))))) + (tr> + (td> :colspan "2" + (csubmit> :id "submit" :value "OK"))))) + (p> + (exception-monitor>) + (hr>) + (h2> "From result:") + (div> (format nil "Name: ~a" (user-name (form-page-user o)))) + (div> (format nil "Surname: ~a" (user-surname (form-page-user o)))) + (div> (format nil "Gender: ~a" (user-gender (form-page-user o)))) + (div> (format nil "Age: ~a" (user-age (form-page-user o))))))) -(lisplet-register-page-location *test-lisplet* 'form-page "/form.html") +(lisplet-register-page-location *test-lisplet* 'form-page "form.html")