[claw-cvs] r5 - in trunk/main/claw-core: src tests tests/img
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Fri Feb 15 10:27:32 UTC 2008
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)
More information about the Claw-cvs
mailing list