[claw-cvs] r46 - in trunk/main/claw-core: src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Tue May 13 13:32:44 UTC 2008
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")
More information about the Claw-cvs
mailing list