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)