From achiumenti at common-lisp.net Tue May 6 13:39:12 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Tue, 6 May 2008 09:39:12 -0400 (EDT) Subject: [claw-cvs] r44 - in trunk/main/claw-core: . src tests Message-ID: <20080506133912.D0F777E0A8@common-lisp.net> Author: achiumenti Date: Tue May 6 09:39:11 2008 New Revision: 44 Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/components.lisp 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/src/translators.lisp trunk/main/claw-core/src/validators.lisp trunk/main/claw-core/tests/packages.lisp trunk/main/claw-core/tests/some-page.lisp trunk/main/claw-core/tests/test1.lisp Log: refactoring finished Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Tue May 6 09:39:11 2008 @@ -31,7 +31,7 @@ :name "claw" :author "Andrea Chiumenti" :description "Common Lisp Active Web.A famework to write web applications" - :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time) + :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) :components ((:module src :components ((:file "packages") (:file "misc" :depends-on ("packages")) @@ -42,5 +42,5 @@ (:file "components" :depends-on ("tags")) (:file "validators" :depends-on ("components")) (:file "translators" :depends-on ("validators")) - (:file "lisplet" :depends-on ("components")) - (:file "server" :depends-on ("lisplet")))))) + (:file "server" :depends-on ("components")) + (:file "lisplet" :depends-on ("server")))))) Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Tue May 6 09:39:11 2008 @@ -209,43 +209,33 @@ (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((cinput base-cinput) (page page)) - (let ((visit-object (cinput-visit-object cinput)) + (let ((visit-object (or (cinput-visit-object cinput) page)) (accessor (cinput-accessor cinput)) (writer (cinput-writer cinput)) - (validator (validator cinput)) - (translator (translator cinput)) - (value "")) - (multiple-value-bind (client-id request-value) - (component-id-and-value cinput) - (declare (ignore client-id)) - (setf value - (handler-case - (translator-decode translator cinput) - (error () request-value))) - (unless (null value) + (validator (validator cinput)) + (value (translator-decode (translator cinput) cinput))) + (unless (or (null value) (component-validation-errors cinput)) (when validator (funcall validator value)) (unless (component-validation-errors cinput) - (when (null visit-object) - (setf visit-object page)) - (if (and (null writer) accessor) - (funcall (fdefinition `(setf ,accessor)) value visit-object) - (funcall (fdefinition writer) value visit-object))))))) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) value visit-object) + (funcall (fdefinition writer) value visit-object)))))) (defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t)) (let ((client-id (htcomponent-client-id cinput)) - (page (htcomponent-page cinput)) - (visit-object (cinput-visit-object cinput)) + (visit-object (or (cinput-visit-object cinput) (htcomponent-page cinput))) (accessor (cinput-accessor cinput)) (reader (cinput-reader cinput)) (result-as-list-p (cinput-result-as-list-p cinput)) (value "")) - (when (null visit-object) - (setf visit-object (htcomponent-page cinput))) - (cond - (from-request-p (setf value (page-req-parameter page client-id result-as-list-p))) - ((and (null reader) accessor) (setf value (funcall (fdefinition accessor) visit-object))) - (t (setf value (funcall (fdefinition reader) visit-object)))) + (setf value + (cond + (from-request-p (page-req-parameter (htcomponent-page cinput) + client-id + result-as-list-p)) + ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) + (t (funcall (fdefinition reader) visit-object)))) (values client-id value))) 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 6 09:39:11 2008 @@ -29,6 +29,16 @@ (in-package :claw) +(defgeneric clawserver-register-lisplet (clawserver lisplet) + (:documentation "This method registers a lisplet for request dispatching +- CLAWSERVER the CLAWSERVER instance +- LISPLET the LISPLET instance")) + +(defgeneric clawserver-unregister-lisplet (clawserver lisplet) + (:documentation "This method unregisters a lisplet from request dispatching +- CLAWSERVER the CLAWSERVER instance +- LISPLET the LISPLET instance")) + (defgeneric lisplet-register-function-location (lisplet function location &key welcome-page-p login-page-p) (:documentation "Registers a function into a lisplet for dispatching. parameters: @@ -83,10 +93,15 @@ parameters: - LISPLET the lisplet object.")) +(defgeneric build-lisplet-location (lisplet) + (:documentation "Constructs a full path prepending the lisplet base path to the given location")) + (setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) - (let* ((error-handlers (lisplet-error-handlers (current-lisplet))) + (let* ((error-handlers (if (current-lisplet) + (lisplet-error-handlers (current-lisplet)) + (make-hash-table))) (handler (gethash error-code error-handlers))) (if handler (funcall handler) @@ -127,16 +142,27 @@ (:documentation "A lisplet is a container for resources provided trhough the clawserver. It is similar, for purposes, to a JAVA servlet")) -(defun build-lisplet-location (lisplet location) +(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) + (let ((dispatchers (clawserver-dispatchers clawserver)) + (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))))) + +(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) + (let ((dispatchers (clawserver-dispatchers clawserver)) + (location (lisplet-base-path lisplet))) + (remove-by-location location dispatchers))) + + +(defmethod build-lisplet-location ((lisplet lisplet)) "Constructs a full path prepending the lisplet base path to the given location" - (let ((server-base-path *clawserver-base-path*) - (base-path (lisplet-base-path lisplet))) - (if location - (setf location (format nil "~a/~a" base-path location)) - (setf location base-path)) - (unless (null server-base-path) - (setf location (format nil "~a~a" server-base-path location))) - location)) + (format nil "~a~a" (clawserver-base-path (current-server)) (lisplet-base-path lisplet))) (defmethod lisplet-authentication-type ((lisplet lisplet)) (if (lisplet-login-page lisplet) @@ -144,74 +170,64 @@ :basic)) (defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) - (let ((pages (lisplet-pages lisplet)) - (new-location (build-lisplet-location lisplet location))) + (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) - (sort-dispatchers (push-location-cons - (cons new-location - (create-prefix-dispatcher new-location - function - (lisplet-realm lisplet))) - pages))) + (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p - (setf (lisplet-welcome-page lisplet) new-location)) + (setf (lisplet-welcome-page lisplet) location)) (when login-page-p - (setf (lisplet-login-page lisplet) new-location)))) + (setf (lisplet-login-page lisplet) location)))) (defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p) - (let ((new-location (build-lisplet-location lisplet location))) - (lisplet-register-function-location lisplet - #'(lambda () - (with-output-to-string - (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url new-location)))) - location - :welcome-page-p welcome-page-p - :login-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)) (defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type) - (let ((pages (lisplet-pages lisplet)) - (new-location (build-lisplet-location lisplet location))) + (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) - (sort-dispatchers (push-location-cons - (cons new-location - (if (directory-pathname-p resource-path) - (create-folder-dispatcher-and-handler new-location resource-path) - (create-static-file-dispatcher-and-handler new-location resource-path content-type))) + (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 ((pages (lisplet-pages lisplet))) - (loop for dispatcher in pages - for action = (funcall (cdr dispatcher) *request*) - when action return (funcall action)))) + (let ((dispatchers (lisplet-pages lisplet)) + (rel-script-name (subseq (script-name) (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))))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) - (let ((result nil) - (base-path (build-lisplet-location lisplet nil)) - (uri (request-uri)) + (let ((base-path (build-lisplet-location lisplet)) + (uri (script-name)) (welcome-page (lisplet-welcome-page lisplet))) - (progn - (setf (current-lisplet) lisplet) - (setf (current-realm) (lisplet-realm lisplet)) - (lisplet-check-authorization lisplet) - (when (= (return-code) +http-ok+) - (if (and welcome-page (string= uri base-path)) - (progn - (redirect (lisplet-welcome-page lisplet)) - t) - (progn - (setf result (lisplet-dispatch-request lisplet)) - (when (null result) - (setf (return-code) +http-not-found+)) - result)))))) + (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))))) (defmethod lisplet-protect ((lisplet lisplet) location roles) - (let ((protected-resources (lisplet-protected-resources lisplet)) - (new-location (build-lisplet-location lisplet location))) + (let ((protected-resources (lisplet-protected-resources lisplet))) (setf (lisplet-protected-resources lisplet) - (sort-protected-resources (push-location-cons - (cons new-location roles) + (sort-protected-resources (pushnew-location + (cons location roles) protected-resources))))) (defun redirect-to-https (server request) @@ -231,7 +247,8 @@ (throw 'handler-done nil))))) (defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*)) - (let ((uri (request-uri 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)) @@ -247,9 +264,9 @@ (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 match = (format nil "~a~a" base-path (car protected-resource)) for allowed-roles = (cdr protected-resource) - do (when (cl-ppcre:all-matches match uri) + do (when (starts-with-subseq match uri) (when (lisplet-redirect-protected-resources-p lisplet) (redirect-to-https server request)) (if (null princp) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Tue May 6 09:39:11 2008 @@ -29,14 +29,14 @@ (in-package :claw) -(defvar *clawserver-base-path* nil - "This global variable is used to keep all lisplets \(claw web applications) under a common URL") - (defvar *apache-http-port* 80 "Default apache http port when claw is running in mod_lisp mode") (defvar *apache-https-port* 443 "Default apache https port when claw is running in mod_lisp mode") +(defvar *claw-libraries-resources* () + "Global variable to hold exposed web resources") + (defun strings-to-jsarray (strings) "Transforms a list of strings into a javascript array." (let ((st-size (length strings)) @@ -51,11 +51,10 @@ items (prin1-to-string str)))) items))))))) -(defun sort-dispatchers (dispatchers) - "Sorts a list of dispatcher. A dispatcher is a cons where the car is the url -where the dispatcher method(the cdr) will be called." - (sort dispatchers #'(lambda (item1 item2) - (string-not-lessp (car item1) (car item2))))) +(defun sort-by-location (location-list) + "Sorts a list of location items by their first element (the location itself)." + (sort location-list #'(lambda (item1 item2) + (string-not-lessp (first item1) (first item2))))) (defun sort-protected-resources (protected-resources) "Sorts a list of protected resources. A protected resource is a cons where the car is the url @@ -63,20 +62,20 @@ (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 (item) (string= (car item) location)) cons-list)) - -(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-by-location (car location-cons) cons-list))) - (setf result (push location-cons result)))) +(defun remove-by-location (location location-list) + "Removes an item from LOCATION-LIST checking its first element +against the LOCATION parameter" + (delete-if #'(lambda (item) (string= (first item) location)) location-list)) + +(defun pushnew-location (location-items location-list) + "Isert a new location info items into a list, or replace the one that has the same location +registered (its first element)." + (let ((result (remove-by-location (first location-items) location-list))) + (setf result (push location-items result)))) -(defun start-session () +(defun claw-start-session () "Starts a session bound to the current lisplet base path" - (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet))))) + (start-session (format nil "~a/" (build-lisplet-location (current-lisplet))))) (defun current-page (&optional (request *request*)) @@ -119,7 +118,7 @@ (defun (setf current-principal) (principal &optional (session *session*)) "Setf the principal(user) that logged into the application" (unless session - (setf session (start-session))) + (setf session (claw-start-session))) (setf (session-value 'principal session) principal)) (defun user-in-role-p (roles &optional (session *session*)) @@ -211,7 +210,7 @@ "This function forces the locale for the current user, binding it to the user session, that is created if no session exists." (unless session - (setf session (start-session))) + (setf session (claw-start-session))) (setf (session-value 'locale session) locale)) (defun validation-errors (&optional (request *request*)) @@ -272,4 +271,33 @@ "Yes") (if reserved-parameters (format nil "~{:~a ~}" (eval reserved-parameters)) - "NONE")))) \ No newline at end of file + "NONE")))) + +(defun register-library-resource (location resource-path &optional content-type) + "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." + (setf *claw-libraries-resources* + (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 location)))) + resource-path))) + (handle-static-file resource-full-path content-type))) + #'(lambda () (handle-static-file resource-path content-type)))) + *claw-libraries-resources*)))) + +(defun uri-to-pathname (uri) + "Convert an URI to a pathname" + (let* ((splitted-uri (split-sequence #\/ uri)) + (directory-list (butlast splitted-uri)) + (file (first (last splitted-uri))) + (pos (position #\. file :from-end t)) + (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) + (list (subseq file 0 pos)(subseq file (1+ pos))) + (list file)))) + (make-pathname :directory directory-list + :name (first file-name-and-type) + :type (second file-name-and-type)))) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Tue May 6 09:39:11 2008 @@ -33,8 +33,8 @@ (export 'HUNCHENTOOT::SESSION-REALM 'HUNCHENTOOT) (defpackage :claw - (:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time) - (:shadow :flatten :start-session) + (:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) + (:shadow :flatten) (:documentation "A comprehensive web application framework and server for the Common Lisp programming language") (:export :*html-4.01-strict* :*html-4.01-transitional* @@ -206,9 +206,11 @@ :lisplet-register-function-location :lisplet-register-resource-location :lisplet-protect - :start-session + :lisplet-authentication-type + :claw-start-session ;; clawserver - :clawserver + :clawserver + :clawserver-base-path :clawserver-register-lisplet :clawserver-unregister-lisplet :clawserver-start @@ -249,6 +251,7 @@ :page-current-component :user-in-role-p :login + :register-library-resource ;;i18n :message-dispatcher :message-dispatch @@ -268,11 +271,11 @@ :validate :validation-errors :component-validation-errors - :validator-required - :validator-size - :validator-range - :validator-number - :validator-integer - :validator-date-range + :validate-required + :validate-size + :validate-range + :validate-number + :validate-integer + :validate-date-range :exception-monitor :exception-monitor>)) \ No newline at end of file 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 6 09:39:11 2008 @@ -1,4 +1,4 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: src/server.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. @@ -29,18 +29,8 @@ (in-package :claw) -(defgeneric clawserver-register-lisplet (clawserver lisplet) - (:documentation "This method registers a lisplet for request dispatching -- CLAWSERVER the CLAWSERVER instance -- LISPLET the LISPLET instance")) - -(defgeneric clawserver-unregister-lisplet (clawserver lisplet) - (:documentation "This method unregisters a lisplet from request dispatching -- CLAWSERVER the CLAWSERVER instance -- LISPLET the LISPLET instance")) - (defgeneric clawserver-dispatch-request (clawserver) - (:documentation "Dispatches http requests through registered lisplets")) + (:documentation "Dispatches http requests through registered dispatchers")) (defgeneric clawserver-dispatch-method (clawserver) (:documentation "Uses CLAWSERVER-DISPATCH-REQUEST to perform dispatching")) @@ -193,7 +183,10 @@ (format nil "The requested resource (~a) is not available." (request-uri *request*)))) (defclass clawserver () - ((port :initarg :port + ((base-path :initarg :base-path + :accessor clawserver-base-path + :documentation "This slot is used to keep all server resources under a common URL") + (port :initarg :port :reader clawserver-port :documentation "Returns the claw server http port") (sslport :initarg :sslport @@ -252,10 +245,12 @@ (sslserver :initform nil :accessor clawserver-sslserver :documentation "The hunchentoot server dispatching https requests.") - (lisplets :initform nil - :accessor clawserver-lisplets + (dispatchers :initform nil + :accessor clawserver-dispatchers :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is a dispatcher for that lisplet")) - (:default-initargs :address nil + (:default-initargs :base-path "" + :use-apache-log-p nil + :address nil :name (gensym) :sslname (gensym) :port 80 @@ -295,31 +290,7 @@ (when (eq use-apache-log-p :undefined) (setf (clawserver-use-apache-log-p clawserver) (getf keys :mod-lisp-p))) #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined) - (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) - -(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) - (let ((lisplets (clawserver-lisplets clawserver)) - (server-base-path *clawserver-base-path*) - (location (lisplet-base-path lisplet))) - (unless (null server-base-path) - (setf location (format nil "~@[~a~]~a" server-base-path location))) - (setf (clawserver-lisplets clawserver) (sort-dispatchers (push-location-cons - (cons location - (create-prefix-dispatcher - location - #'(lambda () - (lisplet-dispatch-method lisplet)) - (lisplet-realm lisplet))) - lisplets))))) - -(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) - (let ((lisplets (clawserver-lisplets clawserver)) - (server-base-path *clawserver-base-path*) - (location (lisplet-base-path lisplet))) - (unless (null server-base-path) - (setf location (format nil "~@[~a~]~a" server-base-path location))) - (remove-by-location location lisplets))) - + (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) ;;;-------------------------- WRITERS ---------------------------------------- @@ -399,33 +370,49 @@ (setf (slot-value clawserver 'ssl-privatekey-password) ssl-privatekey-password)) ;;;-------------------------- METHODS ---------------------------------------- + (defmethod clawserver-register-configuration ((clawserver clawserver) realm (configuration configuration)) (setf (gethash realm (clawserver-login-config clawserver)) configuration)) -(defmethod clawserver-dispatch-request ((clawserver clawserver)) - (let ((lisplets (clawserver-lisplets clawserver))) - (loop for dispatcher in lisplets - for action = (funcall (cdr dispatcher) *request*) - when action return (funcall action)))) +(defmethod clawserver-dispatch-request ((clawserver clawserver)) + (let ((base-path (clawserver-base-path clawserver)) + (dispatchers (clawserver-dispatchers clawserver)) + (script-name (script-name)) + (rel-script-name)) + (setf (current-server) clawserver) + (when (starts-with-subseq script-name base-path) + (setf rel-script-name (subseq script-name (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))))) + (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))))))))) + (defmethod clawserver-dispatch-method ((clawserver clawserver)) - (let ((result nil)) - (progn - ;(setf (aux-request-value 'clawserver) clawserver) - (setf (current-server) clawserver) - (setf result (clawserver-dispatch-request clawserver)) - (if (null result) + (let ((result (clawserver-dispatch-request clawserver))) + (if (null result) #'(lambda () (when (= (return-code) +http-ok+) - (setf (return-code *reply*) +http-not-found+))) - #'(lambda () result))))) + (setf (return-code *reply*) +http-not-found+))) + #'(lambda () result)))) (defmethod clawserver-start ((clawserver clawserver)) (let ((port (clawserver-port clawserver)) (sslport (clawserver-sslport clawserver)) (address (clawserver-address clawserver)) (dispatch-table (list #'(lambda (request) - (declare (ignorable request)) - (clawserver-dispatch-method clawserver)))) + (declare (ignorable request)) + (clawserver-dispatch-method clawserver)))) (name (clawserver-name clawserver)) (sslname (clawserver-sslname clawserver)) (mod-lisp-p (clawserver-mod-lisp-p clawserver)) @@ -476,8 +463,8 @@ ;;;---------------------------------------------------------------------------- (defun login (&optional (request *request*)) "Perform user authentication for the reaml where the request has been created" - (let* ((server (current-server request));(aux-request-value 'clawserver)) - (realm (current-realm request));(aux-request-value 'realm)) + (let* ((server (current-server request)) + (realm (current-realm request)) (login-config (gethash realm (clawserver-login-config server)))) (configuration-login login-config request))) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Tue May 6 09:39:11 2008 @@ -997,7 +997,6 @@ :documentation "Determines if the component accepts informal parameters")) (:default-initargs :informal-parameters nil :reserved-parameters nil - :parameters nil :allow-informal-parameters t) (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Tue May 6 09:39:11 2008 @@ -74,7 +74,7 @@ (defmethod translator-encode ((translator translator-integer) (wcomponent cinput)) (let* ((page (htcomponent-page wcomponent)) - (visit-object (cinput-visit-object wcomponent)) + (visit-object (or (cinput-visit-object wcomponent) page)) (accessor (cinput-accessor wcomponent)) (reader (cinput-reader wcomponent)) (grouping-size (translator-grouping-size translator)) @@ -90,8 +90,6 @@ (if (component-validation-errors wcomponent) value (progn - (when (null visit-object) - (setf visit-object (htcomponent-page wcomponent))) (setf value (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) @@ -100,13 +98,16 @@ (format nil control-string value)))))) (defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent)) - (let* ((thousand-separator (translator-thousand-separator translator))) - (multiple-value-bind (client-id new-value) + (let ((thousand-separator (translator-thousand-separator translator))) + (multiple-value-bind (client-id value) (component-id-and-value wcomponent) - (declare (ignore client-id)) - (if thousand-separator - (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value "")) - (parse-integer new-value))))) + (handler-case + (if thousand-separator + (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) + (parse-integer value)) + (error () (progn + (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label wcomponent))) + value)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;; @@ -131,65 +132,61 @@ (defmethod translator-encode ((translator translator-number) (wcomponent cinput)) (let* ((page (htcomponent-page wcomponent)) - (visit-object (cinput-visit-object wcomponent)) + (visit-object (or (cinput-visit-object wcomponent) page)) (accessor (cinput-accessor wcomponent)) (reader (cinput-reader wcomponent)) (thousand-separator (translator-thousand-separator translator)) (grouping-size (translator-grouping-size translator)) (decimal-digits (translator-decimal-digits translator)) (decimals-separator (translator-decimals-separator translator)) - (signum-directive (if (translator-always-show-signum translator) - "@" - "")) + (signum-directive (if (translator-always-show-signum translator) "@" "")) (integer-control-string (if thousand-separator - (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - + (format nil "~~~d,',v:~aD" grouping-size signum-directive) + (format nil "~~~ad" signum-directive))) (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) (if (component-validation-errors wcomponent) value - (progn - (when (null visit-object) - (setf visit-object (htcomponent-page wcomponent))) - (multiple-value-bind (int-value dec-value) - (floor (cond - ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) - (progn - (setf dec-value (coerce dec-value 'float)) - (format nil "~a~a" (if thousand-separator - (string-trim " " (format nil integer-control-string thousand-separator int-value)) - (format nil integer-control-string int-value)) - (cond - ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) - (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) - (decimal-digits - (let ((frac-part (subseq (format nil "~f" dec-value) 2))) - (if (> (length frac-part) decimal-digits) - (setf frac-part (subseq frac-part 0 decimal-digits)) - (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0)))) - (format nil "~a~a" decimals-separator frac-part))) - (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))))) + (multiple-value-bind (int-value dec-value) + (floor (cond + ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) + (t (funcall (fdefinition reader) visit-object)))) + (setf dec-value (coerce dec-value 'float)) + (format nil "~a~a" + (if thousand-separator + (string-trim " " (format nil integer-control-string thousand-separator int-value)) + (format nil integer-control-string int-value)) + (cond + ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) + (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) + (decimal-digits + (let ((frac-part (subseq (format nil "~f" dec-value) 2))) + (if (> (length frac-part) decimal-digits) + (setf frac-part (subseq frac-part 0 decimal-digits)) + (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0)))) + (format nil "~a~a" decimals-separator frac-part))) + (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))) (defmethod translator-decode ((translator translator-number) (wcomponent wcomponent)) - (let* ((thousand-separator (translator-thousand-separator translator)) - (type (translator-coerce translator)) - (int-value) - (dec-value)) - (multiple-value-bind (client-id new-value) - (component-id-and-value wcomponent) - (declare (ignore client-id)) - (when thousand-separator - (setf new-value (regex-replace-all (format nil "~a" thousand-separator) new-value ""))) - (let ((decomposed-string (all-matches-as-strings "[0-9]+" new-value)) - (result)) - (setf int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string))) - dec-value (expt 10 (length (second decomposed-string))) - result (/ int-value dec-value)) - (if (integerp result) - result - (coerce result type)))))) + (let ((thousand-separator (translator-thousand-separator translator)) + (type (translator-coerce translator)) + (new-value)) + (multiple-value-bind (client-id value) + (component-id-and-value wcomponent) + (if thousand-separator + (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value "")) + (setf new-value value)) + (handler-case + (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value)) + (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))) + (dec-value (expt 10 (length (second decomposed-string)))) + (result (/ int-value dec-value))) + (if (integerp result) + result + (coerce result type))) + (error () (progn + (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label wcomponent))) + value)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -204,14 +201,14 @@ (:default-initargs :local-time-format '(:month "/" :date "/" :year)) (:documentation "A translator object encodes and decodes local-date object value passed to a html input component. When decoding the input compoenent value string to a local-time instance -if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATOR-DATE\". +if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATE-DATE\". The argument for the message will be the :label attribute of the COMPONENT and the input component string value.")) (defmethod translator-encode ((translator translator-date) (wcomponent cinput)) (let* ((page (htcomponent-page wcomponent)) - (visit-object (cinput-visit-object wcomponent)) + (visit-object (or (cinput-visit-object wcomponent) page)) (accessor (cinput-accessor wcomponent)) (reader (cinput-reader wcomponent)) (local-time-format (translator-local-time-format translator)) @@ -219,15 +216,11 @@ (if (component-validation-errors wcomponent) value (progn - (when (null visit-object) - (setf visit-object (htcomponent-page wcomponent))) (setf value (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) (if (and value (not (stringp value))) - (progn - (local-time-to-string value - local-time-format)) + (local-time-to-string value local-time-format) value))))) (defmethod translator-decode ((translator translator-date) (wcomponent wcomponent)) @@ -279,7 +272,7 @@ (and (> month 0) (<= month 12)) (and (> day 0) (<= day (days-in-month month year)))) :component wcomponent - :message (format nil (do-message "VALIDATOR-DATE" "Field ~a is not a valid date or wrong format: ~a") + :message (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") (label wcomponent) old-value)) (if (component-validation-errors wcomponent) Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Tue May 6 09:39:11 2008 @@ -67,19 +67,19 @@ (unless test (add-exception client-id message)))) -(defun validator-required (component value) - "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be null.\" is sent with key \"VALIDATOR-REQUIRED\". +(defun validate-required (component value) + "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be null.\" is sent with key \"VALIDATE-REQUIRED\". The argument for the message will be the :label attribute of the COMPONENT." (when (stringp value) (validate (and value (string-not-equal value "")) :component component - :message (format nil (do-message "VALIDATOR-REQUIRED" "Field ~a may not be null.") (label component))))) + :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be null.") (label component))))) -(defun validator-size (component value &key min-size max-size) +(defun validate-size (component value &key min-size max-size) "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. -If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATOR-SIZE-MIN\". +If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value. -If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATOR-SIZE-MAX\". +If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX-ZIZE value." (let ((value-len 0)) (when value @@ -89,27 +89,27 @@ (when min-size (validate (>= value-len min-size) :component component - :message (format nil (do-message "VALIDATOR-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) + :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) (label component) min-size))) (when max-size (validate (<= value-len max-size) :component component - :message (format nil (do-message "VALIDATOR-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) + :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) (label component) max-size))))))) -(defun validator-range (component value &key min max) +(defun validate-range (component value &key min max) "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. -If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATOR-RANGE-MIN\". +If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN value. -If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATOR-RANGE-MAX\". +If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX value." (when value (and (when min (validate (>= value min) :component component - :message (format nil (do-message "VALIDATOR-RANGE-MIN" "Field ~a is not greater then or equal to ~d") + :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") (label component) (if (typep min 'ratio) (coerce min 'float) @@ -117,43 +117,43 @@ (when max (validate (<= value max) :component component - :message (format nil (do-message "VALIDATOR-RANGE-MAX" "Field ~a is not less then or equal to ~d") + :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") (label component) (if (typep max 'ratio) (coerce max 'float) max))))))) -(defun validator-number (component value &key min max) +(defun validate-number (component value &key min max) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. -If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATOR-NUMBER\". +If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\". The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (numberp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (label component))) - (validator-range component value :min min :max max))))) + :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))) + (validate-range component value :min min :max max))))) -(defun validator-integer (component value &key min max) +(defun validate-integer (component value &key min max) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. -If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATOR-INTEGER\". +If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\". The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (integerp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (label component))) - (validator-range component value :min min :max max))))) + :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))) + (validate-range component value :min min :max max))))) -(defun validator-date-range (component value &key min max (use-date-p t) use-time-p) +(defun validate-date-range (component value &key min max (use-date-p t) use-time-p) "Checks if the input field VALUE is a date between min and max. If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time. If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time. If :USE-DATE-P and :USE-TIME-P are both not nil or nil, validation is made considering the date and time part of local-time. -If value is less then the date passed to :MIN, a localizable message \"Field ~a is less then ~a.\" is sent with key \"VALIDATOR-DATE-RANGE-MIN\". +If value is less then the date passed to :MIN, a localizable message \"Field ~a is less then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MIN parsed with the :LOCAL-TIME-FORMAT keyword. -If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATOR-DATE-RANGE-MAX\". +If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword." (unless (component-validation-errors component) (let ((local-time-format '(:date "-" :month "-" :year)) @@ -180,13 +180,13 @@ (and (when min (validate (local-time> new-value min) :component component - :message (format nil (do-message "VALIDATOR-DATE-RANGE-MIN" "Field ~a is less then ~a.") + :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") (label component) (local-time-to-string min local-time-format)))) (when max (validate (local-time< new-value max) :component component - :message (format nil (do-message "VALIDATOR-DATE-RANGE-MAX" "Field ~a is greater then ~a.") + :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") (label component) (local-time-to-string max local-time-format)))))))) @@ -212,7 +212,7 @@ (validation-errors (aux-request-value :validation-errors))) (when validation-errors (ul> :static-id client-id - (wcomponent-informal-parameters cform) + (wcomponent-informal-parameters exception-monitor) (loop for component-exceptions in validation-errors collect (loop for message in (cdr component-exceptions) collect (li> message))))))) Modified: trunk/main/claw-core/tests/packages.lisp ============================================================================== --- trunk/main/claw-core/tests/packages.lisp (original) +++ trunk/main/claw-core/tests/packages.lisp Tue May 6 09:39:11 2008 @@ -30,6 +30,6 @@ (in-package :cl-user) (defpackage :claw-tests - (:use :cl :claw :hunchentoot :local-time) + (:use :cl :hunchentoot :claw :local-time) (:export :claw-tst-start :claw-tst-stop)) \ No newline at end of file Modified: trunk/main/claw-core/tests/some-page.lisp ============================================================================== --- trunk/main/claw-core/tests/some-page.lisp (original) +++ trunk/main/claw-core/tests/some-page.lisp Tue May 6 09:39:11 2008 @@ -29,9 +29,10 @@ (in-package :claw-tests) -(defcomponent inspector () +(defclass inspector (wcomponent) ((ref-id :initarg :ref-id - :reader ref-id))) + :reader ref-id)) + (:metaclass metacomponent)) (defmethod wcomponent-template ((inspector inspector)) (div> :static-id (htcomponent-client-id inspector) @@ -54,4 +55,4 @@ (div> :static-id hidden-component-id :style "display: none;" rnd-value) (inspector> :id "inspector" :ref-id hidden-component-id "Show value"))))) -(lisplet-register-page-location *test-lisplet* 'some-page "some-page.html") +(lisplet-register-page-location *test-lisplet* 'some-page "/some-page.html") 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 6 09:39:11 2008 @@ -29,13 +29,16 @@ (in-package :claw-tests) -(setf *default-content-type* "text/html; charset=UTF-8") +(setf hunchentoot:*default-content-type* "text/html; charset=UTF-8") + +(setf hunchentoot:*rewrite-for-session-urls* nil) -(setf *rewrite-for-session-urls* nil) (defvar *this-file* (load-time-value (or #.*compile-file-pathname* *load-pathname*))) -(setf *clawserver-base-path* "/claw") + +(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)) @@ -48,29 +51,33 @@ (simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome") (simple-message-dispatcher-add-message *lisplet-messages* "it" "WELCOME" "Benvenuto") -(simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATOR-REQUIRED" "Il campo ~a non pu? essere vuoto!") +(simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non pu? essere vuoto!") (defvar *test-lisplet*) (setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" - ));:message-dispatcher *lisplet-messages*)) + :redirect-protected-resources-p t)) (defvar *test-lisplet2*) (setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2")) -;;(defparameter *clawserver* (make-instance 'clawserver :port 4242)) +;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw")) -(defvar *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 - :mod-lisp-p nil - :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" - :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) +(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")) -(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*) (defun test-configuration-do-login (request user password) + (declare (ignore request)) (let ((session *session*)) (when (and (string-equal user "kiuma") (string-equal password "password")) @@ -130,10 +137,10 @@ (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")) +(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) ()) @@ -145,6 +152,8 @@ "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" @@ -157,7 +166,7 @@ (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) +(lisplet-register-page-location *test-lisplet* 'index-page "/index.html" :welcome-page-p t) (defclass msie-p (wcomponent) () @@ -189,30 +198,30 @@ (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 () + (lambda () (let ((path (test-image-file))) - (setf (content-type) (mime-type path)) + (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" ) + "/images/matrix2.jpg" ) ;;;--------------------realm test page-------------------------------- (defclass realm-page (page) ()) (defmethod page-content ((o realm-page)) - (when (null *session*) - (start-session)) + (when (null hunchentoot:*session*) + (claw-start-session)) (unless (session-value 'RND-NUMBER) (setf (session-value 'RND-NUMBER) (random 1000))) (site-template> :title "Realm test page" @@ -228,13 +237,13 @@ (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) (li> "Remote Addr: " (session-remote-addr *session*)) (li> "User agent: " (session-user-agent *session*)) - (li> "Lisplet Realm: " (lisplet-realm (page-lisplet o))) + (li> "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) ()) @@ -262,7 +271,7 @@ :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-------------------------------- @@ -307,7 +316,7 @@ (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 @@ -378,7 +387,7 @@ :type "text" :label "Name" :validator #'(lambda (value) - (validator-required (page-current-component o) value)) + (validate-required (page-current-component o) value)) :accessor 'form-page-name)"*")) (tr> :id "messaged" (td> (with-message "SURNAME" "SURNAME")) @@ -387,8 +396,8 @@ :type "text" :label "Surname" :validator #'(lambda (value) - (validator-required (page-current-component o) value) - (validator-size (page-current-component o) value :min-size 1 :max-size 20)) + (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") @@ -411,11 +420,11 @@ :translator (make-instance 'translator-integer :thousand-separator #\') :validator #'(lambda (value) (let ((component (page-current-component o))) - (validator-required component value) - (validator-integer component value :min 1 :max 2000))) + (validate-required component value) + (validate-integer component value :min 1 :max 2000))) :accessor 'form-page-age)"*")) (tr> - (td> "Bithday") + (td> "Birthday") (td> (cinput> :id "bday" :type "text" @@ -423,7 +432,7 @@ :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) :validator #'(lambda (value) (let ((component (page-current-component o))) - (validator-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) + (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") @@ -436,8 +445,8 @@ :thousand-separator #\') :validator #'(lambda (value) (let ((component (page-current-component o))) - (validator-required component value) - (validator-number component value :min 1000.01 :max 500099/100))) + (validate-required component value) + (validate-number component value :min 1000.01 :max 500099/100))) :accessor 'form-page-capital)"*")) (tr> (td> "Colors") @@ -466,7 +475,7 @@ (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") From achiumenti at common-lisp.net Mon May 12 07:10:13 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Mon, 12 May 2008 03:10:13 -0400 (EDT) Subject: [claw-cvs] r45 - in trunk/main/claw-core: . src Message-ID: <20080512071013.BB1B733079@common-lisp.net> Author: achiumenti Date: Mon May 12 03:10:02 2008 New Revision: 45 Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/tags.lisp Log: some indentaion corrected, informal parameters rendering corrected Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Mon May 12 03:10:02 2008 @@ -33,14 +33,14 @@ :description "Common Lisp Active Web.A famework to write web applications" :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) :components ((:module src - :components ((:file "packages") - (:file "misc" :depends-on ("packages")) - (:file "i18n" :depends-on ("packages")) - (:file "locales" :depends-on ("i18n")) - (:file "hunchentoot-overrides" :depends-on ("packages")) - (:file "tags" :depends-on ("misc")) - (:file "components" :depends-on ("tags")) - (:file "validators" :depends-on ("components")) - (:file "translators" :depends-on ("validators")) - (:file "server" :depends-on ("components")) - (:file "lisplet" :depends-on ("server")))))) + :components ((:file "packages") + (:file "misc" :depends-on ("packages")) + (:file "i18n" :depends-on ("packages")) + (:file "locales" :depends-on ("i18n")) + (:file "hunchentoot-overrides" :depends-on ("packages")) + (:file "tags" :depends-on ("misc")) + (:file "components" :depends-on ("tags")) + (:file "validators" :depends-on ("components")) + (:file "translators" :depends-on ("validators")) + (:file "server" :depends-on ("components")) + (:file "lisplet" :depends-on ("server")))))) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Mon May 12 03:10:02 2008 @@ -204,7 +204,7 @@ (defmethod lisplet-dispatch-request ((lisplet lisplet)) (let ((dispatchers (lisplet-pages lisplet)) - (rel-script-name (subseq (script-name) (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) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Mon May 12 03:10:02 2008 @@ -40,27 +40,27 @@ (defun strings-to-jsarray (strings) "Transforms a list of strings into a javascript array." (let ((st-size (length strings)) - (items "")) + (items "")) (cond ((= st-size 0) "[]") - ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) - (t (format nil (format nil "[~a~a]" - (prin1-to-string (first strings)) - (progn - (dolist (str (rest strings)) - (setf items (format nil "~a,~a" - items (prin1-to-string str)))) - items))))))) - + ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) + (t (format nil (format nil "[~a~a]" + (prin1-to-string (first strings)) + (progn + (dolist (str (rest strings)) + (setf items (format nil "~a,~a" + items (prin1-to-string str)))) + items))))))) + (defun sort-by-location (location-list) "Sorts a list of location items by their first element (the location itself)." (sort location-list #'(lambda (item1 item2) - (string-not-lessp (first item1) (first item2))))) + (string-not-lessp (first item1) (first item2))))) (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))))) + (string-lessp (car item1) (car item2))))) (defun remove-by-location (location location-list) "Removes an item from LOCATION-LIST checking its first element @@ -140,54 +140,54 @@ (let ((result result-list)) (loop for element in tree do (cond - ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) - (t (push element result)))) + ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) + (t (push element result)))) (nreverse result))) (defun msie-p (&optional (request *request*)) "Returns nil when the calling browser is not the evil of MSIE" (let* ((header-props (headers-in request)) - (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value)))))) - (when user-agent - (all-matches "MSIE" (string-upcase (cdr user-agent)))))) + (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value)))))) + (when user-agent + (all-matches "MSIE" (string-upcase (cdr user-agent)))))) (defmacro with-message (key &optional (default "") locale) -"Returns a lambda function that can localize a message by its key. + "Returns a lambda function that can localize a message by its key. The first message dispatching is made by the lisplet, then, if the message is not already vlorized the computation is left to the current rendering page, then to the current rendering web component. If the message is null after these passages the default value is used." (let ((current-lisplet (gensym)) - (current-page (gensym)) - (current-component (gensym)) - (result (gensym)) - (key-val key) - (locale-val (gensym)) - (default-val default)) + (current-page (gensym)) + (current-component (gensym)) + (result (gensym)) + (key-val key) + (locale-val (gensym)) + (default-val default)) `#'(lambda () - (let ((,current-lisplet (current-lisplet)) - (,current-page (current-page)) - (,current-component (current-component)) - (,locale-val ,locale) - (,result)) - (unless ,locale-val - (setf ,locale-val (user-locale))) - (when ,current-lisplet - (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) - (when (and (null ,result) ,current-page) - (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) - (when (and (null ,result) ,current-component) - (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) - (when (null ,result) - (setf ,locale-val "") - (when ,current-lisplet - (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) - (when (and (null ,result) ,current-page) - (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) - (when (and (null ,result) ,current-component) - (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))) - (if ,result - ,result - ,default-val))))) + (let ((,current-lisplet (current-lisplet)) + (,current-page (current-page)) + (,current-component (current-component)) + (,locale-val ,locale) + (,result)) + (unless ,locale-val + (setf ,locale-val (user-locale))) + (when ,current-lisplet + (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) + (when (and (null ,result) ,current-page) + (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when (and (null ,result) ,current-component) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) + (when (null ,result) + (setf ,locale-val "") + (when ,current-lisplet + (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) + (when (and (null ,result) ,current-page) + (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when (and (null ,result) ,current-component) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))) + (if ,result + ,result + ,default-val))))) (defun do-message (key &optional (default "") locale) "This function calls the lambda function returned by the WITH-MESSAGE macro." @@ -196,14 +196,14 @@ (defun user-locale (&optional (request *request*) (session *session*)) "This function returns the user locale. If no locale was directly set, the browser default locale is used." (let ((locale (when session - (session-value 'locale session)))) + (session-value 'locale session)))) (unless locale (setf locale (first (loop for str in (all-matches-as-strings - "[A-Z|a-z|_]+" - (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_")) - collect (if (> (length str) 2) - (string-upcase str :start 2) - str))))) + "[A-Z|a-z|_]+" + (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_")) + collect (if (> (length str) 2) + (string-upcase str :start 2) + str))))) locale)) (defun (setf user-locale) (locale &optional (session *session*)) @@ -231,12 +231,12 @@ "Returns the first class default init arg value matching matching the given INITARG" (loop for current-initarg in initargs do (when (eq (first current-initarg) initarg) - (return (second current-initarg))))) + (return (second current-initarg))))) (defmethod initialize-instance :after ((class metacomponent) &key) (let* ((name (class-name class)) - (builder-function (format nil "~a>" name)) - (symbolf (find-symbol builder-function))) + (builder-function (format nil "~a>" name)) + (symbolf (find-symbol builder-function))) (unless symbolf (setf symbolf (intern builder-function))) (setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest))))) @@ -245,15 +245,15 @@ "Helper function that generates documentation for wcomponent init functions" (let* ((class-slots (closer-mop:class-direct-slots class))) (format nil "~{~%~a~}" - (remove-if #'null - (reverse (loop for slot in class-slots - collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot)))) - (when slot-initarg - (format nil - "- :~a ~a" - slot-initarg - (documentation slot 't)))))))))) - + (remove-if #'null + (reverse (loop for slot in class-slots + collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot)))) + (when slot-initarg + (format nil + "- :~a ~a" + slot-initarg + (documentation slot 't)))))))))) + (defvar *id-and-static-id-description* "- :ID The htcomponent-client-id value. CLAW can transform its value to make it univocal - :STATIC-ID Like the :ID parameter, it sets the htcomponent-client-id instance property, but CLAW will not manage its value to manage its univocity." "Description used for describing :ID and :STATIC-ID used in claw component init functions documentation ") @@ -261,43 +261,45 @@ (defun describe-component-behaviour (class) "Returns the behaviour descrioption of a WCOMPONENT init function. If it allows informal parameters, body and the reserved parameters" (let* ((initargs (closer-mop:class-default-initargs class)) - (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters))) + (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters))) (format nil "Allows informal parameters: ~a~%Allows body: ~a~%Reserved parameters: ~a" - (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters) - "Yes" - "No") - (if (find-first-classdefault-initarg-value initargs :empty) - "No" - "Yes") - (if reserved-parameters - (format nil "~{:~a ~}" (eval reserved-parameters)) - "NONE")))) + (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters) + "Yes" + "No") + (if (find-first-classdefault-initarg-value initargs :empty) + "No" + "Yes") + (if reserved-parameters + (format nil "~{:~a ~}" (eval reserved-parameters)) + "NONE")))) (defun register-library-resource (location resource-path &optional content-type) "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." (setf *claw-libraries-resources* - (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 location)))) - resource-path))) - (handle-static-file resource-full-path content-type))) - #'(lambda () (handle-static-file resource-path content-type)))) - *claw-libraries-resources*)))) + (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 location)))) + resource-path))) + (handle-static-file resource-full-path content-type))) + #'(lambda () (handle-static-file resource-path content-type)))) + *claw-libraries-resources*)))) -(defun uri-to-pathname (uri) +(defun uri-to-pathname (uri &optional (relative t)) "Convert an URI to a pathname" (let* ((splitted-uri (split-sequence #\/ uri)) - (directory-list (butlast splitted-uri)) - (file (first (last splitted-uri))) - (pos (position #\. file :from-end t)) - (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) - (list (subseq file 0 pos)(subseq file (1+ pos))) - (list file)))) - (make-pathname :directory directory-list - :name (first file-name-and-type) - :type (second file-name-and-type)))) + (directory-list (butlast splitted-uri)) + (file (first (last splitted-uri))) + (pos (position #\. file :from-end t)) + (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) + (list (subseq file 0 pos)(subseq file (1+ pos))) + (list file)))) + (make-pathname :directory (if relative + (cons :relative directory-list) + (cons :absolute directory-list)) + :name (first file-name-and-type) + :type (second file-name-and-type)))) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Mon May 12 03:10:02 2008 @@ -37,245 +37,248 @@ (:shadow :flatten) (:documentation "A comprehensive web application framework and server for the Common Lisp programming language") (:export :*html-4.01-strict* - :*html-4.01-transitional* - :*html-4.01-frameset* - :*xhtml-1.0-strict* - :*xhtml-1.0-transitional* - :*xhtml-1.0-frameset* - :*default-encoding* - :*rewind-parameter* - :*clawserver-base-path* - :*apache-http-port* - :*apache-https-port* - :*empty-tags* - :tag-emptyp - :strings-to-jsarray - :empty-string-p - :build-tagf - :page - :message-dispatch - :page-lisplet - :page-current-form - :page-req-parameter - :page-script-files - :page-stylesheet-files - :page-class-initscripts - :page-instance-initscripts - :page-current-component - :htcomponent - :htcomponent-page - :htcomponent-body - :htcomponent-empty - :htcomponent-client-id - :htcomponent-script-files - :htcomponent-stylesheet-files - :htcomponent-class-initscripts - :htcomponent-instance-initscript - :tag - :tag-name - :tag-attributes - :htbody - :htscript - :htlink - :hthead - :htstring - :$> - :$raw> - ;empty tags definition - :area> - :base> - :basefont> - :br> - :col> - :frame> - :hr> - :img> - :input> - :isindex> - :link> - :meta> - :param> - ;standard tags - :a> - :abbr> - :acronym> - :address> - :applet> - :b> - :bdo> - :big> - :blockquote> - :body> - :button> - :caption> - :center> - :cite> - :code> - :colgroup> - :dd> - :del> - :dfn> - :dir> - :div> - :dl> - :dt> - :em> - :fieldset> - :font> - :form> - :frameset> - :h1> - :h2> - :h3> - :h4> - :h5> - :h6> - :head> - :html> - :i> - :iframe> - :ins> - :kbd> - :label> - :legend> - :li> - :map> - :menu> - :noframes> - :noscript> - :object> - :ol> - :optgroup> - :option> - :p> - :pre> - :q> - :s> - :samp> - :script> - :select> - :small> - :span> - :strike> - :strong> - :style> - :sub> - :sup> - :table> - :tbody> - :td> - :textarea> - :tfoot> - :th> - :thead> - :title> - :tr> - :tt> - :u> - :ul> - :var> - ;; class modifiers - :page-content - :generate-id - :metacomponent - :wcomponent - :wcomponent-informal-parameters - :wcomponent-allow-informal-parametersp - :wcomponent-template - :wcomponent-before-rewind - :wcomponent-after-rewind - :wcomponent-before-prerender - :wcomponent-after-prerender - :wcomponent-before-render - :wcomponent-after-render - :cform - :cform> - :action-link - :action-link> - :cinput - :cinput> - :cselect - :cselect> - :csubmit - :csubmit> - :submit-link - :submit-link> - :lisplet - :lisplet-pages - :lisplet-register-page-location - :lisplet-register-function-location - :lisplet-register-resource-location - :lisplet-protect - :lisplet-authentication-type - :claw-start-session - ;; clawserver - :clawserver - :clawserver-base-path - :clawserver-register-lisplet - :clawserver-unregister-lisplet - :clawserver-start - :clawserver-stop - :clawserver-port - :clawserver-sslport - :clawserver-address - :clawserver-name - :clawserver-sslname - :clawserver-mod-lisp-p - :clawserver-use-apache-log-p - :clawserver-input-chunking-p - :clawserver-read-timeout - :clawserver-write-timeout - :clawserver-login-config - #+(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 - :msie-p - :*id-and-static-id-description* - :describe-component-behaviour - :describe-html-attributes-from-class-slot-initargs - :clawserver-register-configuration - :configuration - :configuration-login - :principal - :current-principal - :principal-name - :principal-roles - :current-lisplet - :current-server - :current-realm - :current-page - :current-component - :user-locale - :page-current-component - :user-in-role-p - :login - :register-library-resource - ;;i18n - :message-dispatcher - :message-dispatch - :simple-message-dispatcher - :simple-message-dispatcher-add-message - :with-message - :do-message - ;;validation - :translator - :translator-integer - :translator-number - :translator-date - :translator-encode - :translator-decode - :*simple-translator* - :*locales* - :validate - :validation-errors - :component-validation-errors - :validate-required - :validate-size - :validate-range - :validate-number - :validate-integer - :validate-date-range - :exception-monitor - :exception-monitor>)) \ No newline at end of file + :*html-4.01-transitional* + :*html-4.01-frameset* + :*xhtml-1.0-strict* + :*xhtml-1.0-transitional* + :*xhtml-1.0-frameset* + :*default-encoding* + :*rewind-parameter* + :*clawserver-base-path* + :*apache-http-port* + :*apache-https-port* + :*empty-tags* + :tag-emptyp + :strings-to-jsarray + :empty-string-p + :build-tagf + :page + :page-url + :page-lisplet + :page-current-form + :page-req-parameter + :page-script-files + :page-stylesheet-files + :page-class-initscripts + :page-instance-initscripts + :page-current-component + :page-body-init-scripts + :htcomponent + :htcomponent-page + :htcomponent-body + :htcomponent-empty + :htcomponent-client-id + :htcomponent-script-files + :htcomponent-stylesheet-files + :htcomponent-class-initscripts + :htcomponent-instance-initscript + :tag + :tag-name + :tag-attributes + :htbody + :htscript + :htlink + :hthead + :htstring + :$> + :$raw> + ;empty tags definition + :area> + :base> + :basefont> + :br> + :col> + :frame> + :hr> + :img> + :input> + :isindex> + :link> + :meta> + :param> + ;standard tags + :a> + :abbr> + :acronym> + :address> + :applet> + :b> + :bdo> + :big> + :blockquote> + :body> + :button> + :caption> + :center> + :cite> + :code> + :colgroup> + :dd> + :del> + :dfn> + :dir> + :div> + :dl> + :dt> + :em> + :fieldset> + :font> + :form> + :frameset> + :h1> + :h2> + :h3> + :h4> + :h5> + :h6> + :head> + :html> + :i> + :iframe> + :ins> + :kbd> + :label> + :legend> + :li> + :map> + :menu> + :noframes> + :noscript> + :object> + :ol> + :optgroup> + :option> + :p> + :pre> + :q> + :s> + :samp> + :script> + :select> + :small> + :span> + :strike> + :strong> + :style> + :sub> + :sup> + :table> + :tbody> + :td> + :textarea> + :tfoot> + :th> + :thead> + :title> + :tr> + :tt> + :u> + :ul> + :var> + ;; class modifiers + :page-content + :generate-id + :metacomponent + :wcomponent + :wcomponent-informal-parameters + :wcomponent-allow-informal-parametersp + :wcomponent-template + :wcomponent-before-rewind + :wcomponent-after-rewind + :wcomponent-before-prerender + :wcomponent-after-prerender + :wcomponent-before-render + :wcomponent-after-render + :cform + :cform> + :action + :action-link + :action-link> + :cinput + :cinput> + :cselect + :cselect> + :csubmit + :csubmit> + :csubmit-value + :submit-link + :submit-link> + :lisplet + :lisplet-pages + :lisplet-register-page-location + :lisplet-register-function-location + :lisplet-register-resource-location + :lisplet-protect + :lisplet-authentication-type + :claw-start-session + ;; clawserver + :clawserver + :clawserver-base-path + :clawserver-register-lisplet + :clawserver-unregister-lisplet + :clawserver-start + :clawserver-stop + :clawserver-port + :clawserver-sslport + :clawserver-address + :clawserver-name + :clawserver-sslname + :clawserver-mod-lisp-p + :clawserver-use-apache-log-p + :clawserver-input-chunking-p + :clawserver-read-timeout + :clawserver-write-timeout + :clawserver-login-config + #+(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 + :msie-p + :*id-and-static-id-description* + :describe-component-behaviour + :describe-html-attributes-from-class-slot-initargs + :clawserver-register-configuration + :configuration + :configuration-login + :principal + :current-principal + :principal-name + :principal-roles + :current-lisplet + :current-server + :current-realm + :current-page + :current-component + :user-locale + :page-current-component + :user-in-role-p + :login + :register-library-resource + ;;i18n + :message-dispatcher + :message-dispatch + :simple-message-dispatcher + :simple-message-dispatcher-add-message + :with-message + :do-message + ;;validation + :translator + :translator-integer + :translator-number + :translator-date + :translator-encode + :translator-decode + :*simple-translator* + :*locales* + :validate + :validation-errors + :component-validation-errors + :validate-required + :validate-size + :validate-range + :validate-number + :validate-integer + :validate-date-range + :exception-monitor + :exception-monitor>)) \ 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 Mon May 12 03:10:02 2008 @@ -142,7 +142,7 @@ - HTCOMPONENT is the htcomponent instance")) (defgeneric htcomponent-json-print-end-component (htcomponent) - (:documentation "Internal method called to render the json reply during the render cycle phase + (:documentation "Internal method called to render the json reply during the render cycle phase on component end. - HTCOMPONENT is the htcomponent instance")) @@ -173,11 +173,6 @@ (defgeneric (setf slot-initialization) (value wcomponent slot-initarg) (:documentation "Sets a slot by its :INITARG. It's used just after instance creation")) -(defgeneric wcomponent-informal-parameters(wcomponent) - (:documentation "This method returns class informal parameters as an alist (informal parameters are the ones not expected by the component, -usually rendered as tag attributes withot any kind of evaluation) - - WCOMPONENT is the wcomponent instance")) - (defgeneric wcomponent-before-rewind (wcomponent page) (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes. - WCOMPONENT is the tag instance @@ -238,8 +233,8 @@ (defvar *empty-tags* (list "area" "base" "basefont" "br" "col" "frame" - "hr" "img" "input" "isindex" "meta" - "param" "link") + "hr" "img" "input" "isindex" "meta" + "param" "link") "List of html empty tags") (defun request-id-table-map () @@ -249,9 +244,9 @@ (when (boundp '*request*) (let ((id-table-map (aux-request-value :id-table-map))) (if (null id-table-map) - (progn - (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) - id-table-map)))) + (progn + (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) + id-table-map)))) (defun reset-request-id-table-map () "This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness. @@ -262,15 +257,15 @@ (defun parse-htcomponent-function (function-body) "This function parses attributes passed to a htcomponent creation function" (let ((attributes) - (body)) - (loop for last-elem = nil then elem - for elem in function-body - do (if (and (null body) - (or (keywordp elem) - (keywordp last-elem))) - (push elem attributes) - (when elem - (push elem body)))) + (body)) + (loop for last-elem = nil then elem + for elem in function-body + do (if (and (null body) + (or (keywordp elem) + (keywordp last-elem))) + (push elem attributes) + (when elem + (push elem body)))) (list (reverse attributes) (reverse body)))) @@ -278,38 +273,38 @@ "This function is very useful when having references to components id inside component body. When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute." (let* ((id-ht (request-id-table-map)) - (client-id-index (gethash id id-ht 0)) - (result)) + (client-id-index (gethash id id-ht 0)) + (result)) (if (= 0 client-id-index) - (setf result id) - (setf result (format nil "~a_~d" id client-id-index))) + (setf result id) + (setf result (format nil "~a_~d" id client-id-index))) (setf (gethash id id-ht) (1+ client-id-index)) result)) (defun build-tagf (tag-name parent emptyp &rest rest) "This function is used to create a tag object instance - TAG-NAME the a string tag name to create, for example \"span\" -- PARENT the parent class. usually 'TAG +- PARENT the parent class. usually TAG - EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase. - REST a list of attribute/value pairs and the component body" (let* ((fbody (parse-htcomponent-function (flatten rest))) - (id-table-map (request-id-table-map)) - (id (getf (first fbody) :id)) - (static-id (getf (first fbody) :static-id)) - (instance)) + (id-table-map (request-id-table-map)) + (id (getf (first fbody) :id)) + (static-id (getf (first fbody) :static-id)) + (instance)) (when static-id (remf (first fbody) :id) (setf id nil)) (setf instance (make-instance parent - :empty emptyp - :name (string-downcase tag-name) - :attributes (first fbody) - :body (second fbody))) + :empty emptyp + :name (string-downcase tag-name) + :attributes (first fbody) + :body (second fbody))) (if (null static-id) - (when (and id-table-map id) - (setf (htcomponent-client-id instance) - (generate-id id))) - (setf (htcomponent-client-id instance) static-id)) + (when (and id-table-map id) + (setf (htcomponent-client-id instance) + (generate-id id))) + (setf (htcomponent-client-id instance) static-id)) instance)) (defun generate-tagf (tag-name emptyp) @@ -318,12 +313,12 @@ - EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase." (let ((fsymbol (intern (format nil "~a>" (string-upcase tag-name))))) (setf (fdefinition fsymbol) - #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest))) + #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest))) (setf (documentation fsymbol 'function) (format nil "This function generates the ~a<~a> html tag" - (if emptyp - "empty " - "") - tag-name)))) + (if emptyp + "empty " + "") + tag-name)))) ;;;---------------------------------------------------------------- @@ -333,58 +328,58 @@ (defclass simple-message-dispatcher (message-dispatcher) ((locales :initform (make-hash-table :test #'equal) - :accessor simple-message-dispatcher-locales - :documentation "Hash table of locales strings and KEY/VALUE message pairs")) + :accessor simple-message-dispatcher-locales + :documentation "Hash table of locales strings and KEY/VALUE message pairs")) (:documentation "A message disptcher that leave data unchanged during encoding and decoding phases.")) (defclass i18n-aware (message-dispatcher) ((message-dispatcher :initarg :message-dispatcher - :accessor message-dispatcher - :documentation "Reference to a MESSAGE-DISPATCHER instance")) + :accessor message-dispatcher + :documentation "Reference to a MESSAGE-DISPATCHER instance")) (:default-initargs :message-dispatcher nil) (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE")) (defclass page(i18n-aware) ((writer :initarg :writer - :accessor page-writer :documentation "The output stream for this page instance") + :accessor page-writer :documentation "The output stream for this page instance") (lisplet :initarg :lisplet - :reader page-lisplet :documentation "The lisplet that owns this page instance") + :reader page-lisplet :documentation "The lisplet that owns this page instance") (can-print :initform nil - :accessor page-can-print - :documentation "Controls the printing process when a json request is dispatched. + :accessor page-can-print + :documentation "Controls the printing process when a json request is dispatched. Only components with a matching id and their contents can be printed") (script-files :initarg :script-files - :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle") + :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle") (stylesheet-files :initarg :stylesheet-files - :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle") + :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle") (class-initscripts :initarg :class-initscripts - :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle") + :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle") (instancee-initscripts :initarg :instance-initscripts - :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle") + :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle") (indent :initarg :indent - :accessor page-indent :documentation "Determine if the output must be indented or not") + :accessor page-indent :documentation "Determine if the output must be indented or not") (tabulator :initarg :tabulator - :accessor page-tabulator :documentation "Holds the indentation level") + :accessor page-tabulator :documentation "Holds the indentation level") (xmloutput :initarg :xmloutput - :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML") + :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML") (current-form :initform :nil - :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired") + :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired") (doc-type :initarg :doc-type - :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)") + :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)") (lasttag :initform nil - :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering") + :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering") (json-component-count :initarg :json-component-count - :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") + :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") (request-parameters :initarg :request-parameters - :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.") + :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.") (components-stack :initform nil - :accessor page-components-stack - :documentation "A stack of components enetered into rendering process.") + :accessor page-components-stack + :documentation "A stack of components enetered into rendering process.") (content-type :initarg :content-type - :accessor page-content-type - :documentation "Define the content type of the page when rendered") + :accessor page-content-type + :documentation "Define the content type of the page when rendered") (url :initarg :url - :accessor page-url :documentation "The URL provided with this page instance")) + :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t :script-files nil :json-component-count 0 @@ -402,23 +397,23 @@ (defclass htcomponent (i18n-aware) ((page :initarg :page - :reader htcomponent-page :documentation "The owner page") + :reader htcomponent-page :documentation "The owner page") (body :initarg :body - :accessor htcomponent-body :documentation "The tag body") + :accessor htcomponent-body :documentation "The tag body") (client-id :initarg :client-id - :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") + :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") (attributes :initarg :attributes - :accessor htcomponent-attributes :documentation "The tag attributes") + :accessor htcomponent-attributes :documentation "The tag attributes") (empty :initarg :empty - :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag") + :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag") (script-files :initarg :script-files - :accessor htcomponent-script-files :documentation "Page injectable script files") + :accessor htcomponent-script-files :documentation "Page injectable script files") (stylesheet-files :initarg :stylesheet-files - :accessor htcomponent-stylesheet-files :documentation "Page injectable css files") + :accessor htcomponent-stylesheet-files :documentation "Page injectable css files") (class-initscripts :initarg :class-initscripts - :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives") + :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives") (instance-initscript :initarg :instance-initscript - :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) + :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) (:default-initargs :page nil :body nil :client-id nil @@ -432,13 +427,13 @@ (defclass tag (htcomponent) ((name :initarg :name - :reader tag-name :documentation "The tag name to be rendered")) + :reader tag-name :documentation "The tag name to be rendered")) (:default-initargs :name nil) (:documentation "This class is used to render the most part of html tags")) (defclass htstring (htcomponent) ((raw :initarg :raw - :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not")) + :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not")) (:default-initargs :raw nil) (:documentation "Component needed to render strings")) @@ -446,9 +441,9 @@ (defmethod initialize-instance :after ((inst tag) &rest keys) (let ((emptyp (getf keys :empty)) - (body (getf keys :body))) + (body (getf keys :body))) (when (and (not (null emptyp)) - (not (null body))) + (not (null body))) (error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body))))) (defun $> (value) @@ -488,29 +483,29 @@ (build-tagf "head" 'hthead nil rest)) (mapcar #'(lambda (tag-name) (generate-tagf tag-name t)) - ;;Creates empty tag initialization functions. But the ones directly defined - *empty-tags*) + ;;Creates empty tag initialization functions. But the ones directly defined + *empty-tags*) (mapcar #'(lambda (tag-name) (generate-tagf tag-name nil)) - ;;Creates non empty tag initialization functions. But the ones directly defined - '("a" "abbr" "acronym" "address" "applet" - "b" "bdo" "big" "blockquote" "button" - "caption" "center" "cite" "code" "colgroup" - "dd" "del" "dfn" "dir" "div" "dl" "dt" - "em" - "fieldset" "font" "form" "frameset" - "h1" "h2" "h3" "h4" "h5" "h6" "html" - "i" "iframe" "ins" - "kbd" - "label" "legend" "li" - "map" "menu" - "noframes" "noscript" - "object" "ol" "optgroup" "option" - "p" "pre" - "q" - "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup" - "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" - "u" "ul" "var")) + ;;Creates non empty tag initialization functions. But the ones directly defined + '("a" "abbr" "acronym" "address" "applet" + "b" "bdo" "big" "blockquote" "button" + "caption" "center" "cite" "code" "colgroup" + "dd" "del" "dfn" "dir" "div" "dl" "dt" + "em" + "fieldset" "font" "form" "frameset" + "h1" "h2" "h3" "h4" "h5" "h6" "html" + "i" "iframe" "ins" + "kbd" + "label" "legend" "li" + "map" "menu" + "noframes" "noscript" + "object" "ol" "optgroup" "option" + "p" "pre" + "q" + "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup" + "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" + "u" "ul" "var")) (defun tag-emptyp (tag-name) "Returns if a tag defined by the string TAG-NAME is empty" @@ -519,47 +514,47 @@ ;;;--------------------METHODS implementation---------------------------------------------- (defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) (let ((id (getf (htcomponent-attributes htcomponent) :id)) - (static-id (getf (htcomponent-attributes htcomponent) :static-id)) - (client-id (htcomponent-client-id htcomponent))) + (static-id (getf (htcomponent-attributes htcomponent) :static-id)) + (client-id (htcomponent-client-id htcomponent))) (setf (slot-value htcomponent 'page) page) (unless client-id (if static-id - (setf (htcomponent-client-id htcomponent) static-id) - (setf (htcomponent-client-id htcomponent) (generate-id id)))))) + (setf (htcomponent-client-id htcomponent) static-id) + (setf (htcomponent-client-id htcomponent) (generate-id id)))))) (defmethod page-request-parameters ((page page)) (if (and (boundp '*request*) (null (slot-value page 'request-parameters))) - (let ((parameters (append (post-parameters) (get-parameters))) - (pparameters (make-hash-table :test 'equal))) - (loop for kv in parameters - do (setf (gethash (string-upcase (car kv)) pparameters) - (append (gethash (string-upcase (car kv)) pparameters) - (list (cdr kv))))) - (setf (slot-value page 'request-parameters) pparameters)) - (slot-value page 'request-parameters))) + (let ((parameters (append (post-parameters) (get-parameters))) + (pparameters (make-hash-table :test 'equal))) + (loop for kv in parameters + do (setf (gethash (string-upcase (car kv)) pparameters) + (append (gethash (string-upcase (car kv)) pparameters) + (list (cdr kv))))) + (setf (slot-value page 'request-parameters) pparameters)) + (slot-value page 'request-parameters))) (defmethod page-req-parameter ((page page) name &optional as-list) (let ((parameters (page-request-parameters page)) - (retval)) + (retval)) (when parameters (setf retval (gethash (string-upcase name) parameters)) (if (or (null retval) as-list) - retval - (first retval))))) + retval + (first retval))))) (defmethod page-format ((page page) str &rest rest) (let ((jsonp (page-json-id-list page)) - (writer (page-writer page))) + (writer (page-writer page))) (if (null jsonp) - (apply #'format writer str rest) - (apply #'format writer (list - (regex-replace-all "\"" - (regex-replace-all "\\\\\"" - (regex-replace-all "\\n" - (apply #'format nil str rest) - "\\n") - "\\\\\\\"") - "\\\"")))))) + (apply #'format writer str rest) + (apply #'format writer (list + (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + (apply #'format nil str rest) + "\\n") + "\\\\\\\"") + "\\\"")))))) (defmethod page-format-raw ((page page) str &rest rest) (let ((writer (page-writer page))) @@ -577,107 +572,107 @@ (defmethod page-render-headings ((page page)) (let* ((writer (page-writer page)) - (jsonp (page-json-id-list page)) - (encoding (handler-case (format nil "~a" (stream-external-format writer)) - (error () (format nil "~a" *default-encoding*)))) - (xml-p (page-xmloutput page)) - (content-type (page-doc-type page))) + (jsonp (page-json-id-list page)) + (encoding (handler-case (format nil "~a" (stream-external-format writer)) + (error () (format nil "~a" *default-encoding*)))) + (xml-p (page-xmloutput page)) + (content-type (page-doc-type page))) (when (null jsonp) (when xml-p - (page-format-raw page "~%" encoding)) + (page-format-raw page "~%" encoding)) (when content-type - (page-format-raw page "~a~%" content-type))))) + (page-format-raw page "~a~%" content-type))))) (defun json-validation-errors () "Composes the error part for the json reply" (let ((validation-errors (aux-request-value :validation-errors))) (if validation-errors - (strings-to-jsarray - (loop for component-exceptions in validation-errors - collect (format "{~a:~a}"(car component-exceptions) - (strings-to-jsarray (loop for message in (cdr component-exceptions) - collect (prin1-to-string message)))))) - "null"))) + (strings-to-jsarray + (loop for component-exceptions in validation-errors + collect (format "{~a:~a}"(car component-exceptions) + (strings-to-jsarray (loop for message in (cdr component-exceptions) + collect (prin1-to-string message)))))) + "null"))) (defmethod page-render ((page page)) (let ((body (page-content page)) - (jsonp (page-json-id-list page))) + (jsonp (page-json-id-list page))) (setf (hunchentoot:content-type) (page-content-type page)) (if (null body) - (format nil "null body for page ~a~%" (type-of page)) - (progn - (setf (current-page) page) - (page-init page) - (when (page-req-parameter page *rewind-parameter*) - (htcomponent-rewind body page)) - (page-init page) - (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! - (page-render-headings page) - (page-init page) - (when jsonp - (page-format-raw page "{components:{")) - (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! - (when jsonp - (page-format-raw page "},classInjections:\"") - (setf (page-can-print page) t) - (dolist (injection (page-init-injections page)) - (when injection - (htcomponent-render injection page))) - (page-format-raw page "\",instanceInjections:\"") - (let ((init-scripts (htbody-init-scripts-tag page))) - (when init-scripts - (htcomponent-render init-scripts page))) - (page-format-raw page "\",errors:") - (page-format-raw page (json-validation-errors)) - (page-format-raw page "}")))))) + (format nil "null body for page ~a~%" (type-of page)) + (progn + (setf (current-page) page) + (page-init page) + (when (page-req-parameter page *rewind-parameter*) + (htcomponent-rewind body page)) + (page-init page) + (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! + (page-render-headings page) + (page-init page) + (when jsonp + (page-format-raw page "{components:{")) + (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! + (when jsonp + (page-format-raw page "},classInjections:\"") + (setf (page-can-print page) t) + (dolist (injection (page-init-injections page)) + (when injection + (htcomponent-render injection page))) + (page-format-raw page "\",instanceInjections:\"") + (let ((init-scripts (htbody-init-scripts-tag page))) + (when init-scripts + (htcomponent-render init-scripts page))) + (page-format-raw page "\",errors:") + (page-format-raw page (json-validation-errors)) + (page-format-raw page "}")))))) (defmethod page-body-init-scripts ((page page)) (let ((js-body "")) (dolist (current-js (reverse (page-instance-initscripts page))) (setf js-body (format nil "~a~%~a~%" js-body current-js))) (if (string= "" js-body) - js-body - (format nil "~a" js-body)))) + js-body + (format nil "~a" js-body)))) (defmethod page-print-tabulation ((page page)) (let ((jsonp (page-json-id-list page)) - (tabulator (page-tabulator page)) - (indent-p (page-indent page))) + (tabulator (page-tabulator page)) + (indent-p (page-indent page))) (when (and (<= 0 tabulator) indent-p (null jsonp)) (page-format-raw page "~a" - (make-string tabulator :initial-element #\tab))))) + (make-string tabulator :initial-element #\tab))))) (defmethod page-newline ((page page)) (let ((jsonp (page-json-id-list page)) - (indent-p (page-indent page))) + (indent-p (page-indent page))) (when (and indent-p (null jsonp)) (page-format-raw page "~%")))) (defmethod page-init-injections ((page page)) - (let ((tag-list) - (class-init-scripts "")) - (dolist (script (reverse (page-class-initscripts page))) - (setf class-init-scripts (format nil "~a~%~a" - class-init-scripts - script))) - (unless (string= "" class-init-scripts) - (let ((current-js (script> :type "text/javascript"))) - (setf (htcomponent-body current-js) class-init-scripts) - (push current-js tag-list))) - (dolist (js-file (page-script-files page)) - (if (typep js-file 'htcomponent) - (push js-file tag-list) - (let ((current-js (script> :type "text/javascript" :src ""))) - (setf (getf (htcomponent-attributes current-js) :src) js-file) - (push current-js tag-list)))) - (dolist (css-file (page-stylesheet-files page)) - (if (typep css-file 'htcomponent) - (push css-file tag-list) - (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) - (setf (getf (htcomponent-attributes current-css) :href) css-file) - (push current-css tag-list)))) + (let ((tag-list) + (class-init-scripts "")) + (dolist (script (reverse (page-class-initscripts page))) + (setf class-init-scripts (format nil "~a~%~a" + class-init-scripts + script))) + (unless (string= "" class-init-scripts) + (let ((current-js (script> :type "text/javascript"))) + (setf (htcomponent-body current-js) class-init-scripts) + (push current-js tag-list))) + (dolist (js-file (page-script-files page)) + (if (typep js-file 'htcomponent) + (push js-file tag-list) + (let ((current-js (script> :type "text/javascript" :src ""))) + (setf (getf (htcomponent-attributes current-js) :src) js-file) + (push current-js tag-list)))) + (dolist (css-file (page-stylesheet-files page)) + (if (typep css-file 'htcomponent) + (push css-file tag-list) + (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) + (setf (getf (htcomponent-attributes current-css) :href) css-file) + (push current-css tag-list)))) - tag-list)) + tag-list)) (defmethod page-current-component ((page page)) (car (page-components-stack page))) @@ -690,28 +685,28 @@ ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) (let* ((id (htcomponent-client-id htcomponent)) - (page (htcomponent-page htcomponent)) - (print-status (page-can-print page)) - (render-p (member id (page-json-id-list page) :test #'string=))) + (page (htcomponent-page htcomponent)) + (print-status (page-can-print page)) + (render-p (member id (page-json-id-list page) :test #'string=))) (or print-status render-p))) (defmethod htcomponent-json-print-start-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) - (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent))) + (jsonp (page-json-id-list page)) + (id (htcomponent-client-id htcomponent))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (member id jsonp :test #'string-equal)) (when (> (page-json-component-count page) 0) - (page-format page ",")) + (page-format page ",")) (page-format-raw page "~a:\"" id) (incf (page-json-component-count page))))) (defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) - (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent))) + (jsonp (page-json-id-list page)) + (id (htcomponent-client-id htcomponent))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (member id jsonp :test #'string-equal)) (page-format-raw page "\"")))) (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) @@ -746,22 +741,22 @@ (setf (page-can-print page) (htcomponent-can-print htcomponent))) (dolist (tag (htcomponent-body htcomponent)) (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) + (htcomponent-prerender tag page))) (when (null previous-print-status) (setf (page-can-print page) nil)))) (defmethod htcomponent-render ((htcomponent htcomponent) (page page)) (let ((body-list (htcomponent-body htcomponent)) - (previous-print-status (page-can-print page))) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print htcomponent)) (htcomponent-json-print-start-component htcomponent)) (dolist (child-tag body-list) (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (when (null previous-print-status) (setf (page-can-print page) nil) (htcomponent-json-print-end-component htcomponent)))) @@ -774,66 +769,66 @@ (when (htcomponent-attributes tag) (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn - (assert (keywordp k)) - (when (functionp v) - (setf v (funcall v))) - (when (and v (string-not-equal v "")) - (page-format page " ~a=\"~a\"" - (string-downcase (if (eq k :static-id) - "id" - (symbol-name k))) - (let ((s (if (eq k :id) - (prin1-to-string (htcomponent-client-id tag)) - (prin1-to-string v)))) ;escapes double quotes - (subseq s 1 (1- (length s)))))))))) + (assert (keywordp k)) + (when (functionp v) + (setf v (funcall v))) + (when (and v (string-not-equal v "")) + (page-format page " ~a=\"~a\"" + (string-downcase (if (eq k :static-id) + "id" + (symbol-name k))) + (let ((s (if (eq k :id) + (prin1-to-string (htcomponent-client-id tag)) + (prin1-to-string v)))) ;escapes double quotes + (subseq s 1 (1- (length s)))))))))) (defmethod tag-render-starttag ((tag tag) (page page)) (let ((tagname (tag-name tag)) - (emptyp (htcomponent-empty tag)) - (xml-p (page-xmloutput page))) + (emptyp (htcomponent-empty tag)) + (xml-p (page-xmloutput page))) (setf (page-lasttag page) tagname) (page-newline page) (page-print-tabulation page) (page-format page "<~a" tagname) (tag-render-attributes tag page) (if (null emptyp) - (progn - (page-format page ">") - (incf (page-tabulator page))) - (if (null xml-p) - (page-format page ">") - (page-format page "/>"))))) + (progn + (page-format page ">") + (incf (page-tabulator page))) + (if (null xml-p) + (page-format page ">") + (page-format page "/>"))))) (defmethod tag-render-endtag ((tag tag) (page page)) (let ((tagname (tag-name tag)) - (previous-tagname (page-lasttag page)) - (emptyp (htcomponent-empty tag))) + (previous-tagname (page-lasttag page)) + (emptyp (htcomponent-empty tag))) (when (null emptyp) - (progn - (decf (page-tabulator page)) - (if (string= tagname previous-tagname) - (progn - (page-format page "" tagname)) - (progn - (page-newline page) - (page-print-tabulation page) - (page-format page "" tagname))))) + (progn + (decf (page-tabulator page)) + (if (string= tagname previous-tagname) + (progn + (page-format page "" tagname)) + (progn + (page-newline page) + (page-print-tabulation page) + (page-format page "" tagname))))) (setf (page-lasttag page) nil))) (defmethod htcomponent-render ((tag tag) (page page)) (let ((body-list (htcomponent-body tag)) - (previous-print-status (page-can-print page))) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print tag)) (htcomponent-json-print-start-component tag)) (when (or (page-can-print page) previous-print-status) (tag-render-starttag tag page)) (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (when (or (page-can-print page) previous-print-status) (tag-render-endtag tag page)) (unless previous-print-status @@ -844,18 +839,18 @@ (defmethod htcomponent-render ((hthead hthead) (page page)) (when (null (page-json-id-list page)) (let ((body-list (htcomponent-body hthead)) - (injections (page-init-injections page))) + (injections (page-init-injections page))) (tag-render-starttag hthead page) (htcomponent-render (meta> :http-equiv "Content-Type" :content (page-content-type page)) page) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (dolist (injection injections) - (when injection - (htcomponent-render injection page))) + (when injection + (htcomponent-render injection page))) (tag-render-endtag hthead page)))) ;;;========= HTSTRING =================================== @@ -865,35 +860,35 @@ (defmethod htcomponent-render ((htstring htstring) (page page)) (let ((body (htcomponent-body htstring)) - (jsonp (not (null (page-json-id-list page)))) - (print-p (page-can-print page))) + (jsonp (not (null (page-json-id-list page)))) + (print-p (page-can-print page))) (when (and print-p body) (when (functionp body) - (setf body (funcall body))) + (setf body (funcall body))) (when jsonp - (setf body (regex-replace-all "\"" - (regex-replace-all "\\\\\"" - (regex-replace-all "\\n" - body - "\\n") - "\\\\\\\"") - "\\\""))) + (setf body (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + body + "\\n") + "\\\\\\\"") + "\\\""))) (if (htstring-raw htstring) - (page-format-raw page body) - (loop for ch across body - do (case ch - ((#\<) (page-format-raw page "<")) - ((#\>) (page-format-raw page ">")) - ((#\&) (page-format-raw page "&")) - (t (page-format-raw page "~a" ch)))))))) + (page-format-raw page body) + (loop for ch across body + do (case ch + ((#\<) (page-format-raw page "<")) + ((#\>) (page-format-raw page ">")) + ((#\&) (page-format-raw page "&")) + (t (page-format-raw page "~a" ch)))))))) ;;;========= HTSCRIPT =================================== (defmethod htcomponent-prerender((htscript htscript) (page page))) (defmethod htcomponent-render ((htscript htscript) (page page)) (let ((xml-p (page-xmloutput page)) - (body (htcomponent-body htscript)) - (previous-print-status (page-can-print page))) + (body (htcomponent-body htscript)) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print htscript)) (htcomponent-json-print-start-component htscript)) @@ -902,21 +897,21 @@ (when (page-can-print page) (tag-render-starttag htscript page) (when (and (null (getf (htcomponent-attributes htscript) :src)) - (not (null (htcomponent-body htscript)))) - (if (null xml-p) - (page-format page "~%//") - (page-format page "~%//]]>"))) + (not (null (htcomponent-body htscript)))) + (if (null xml-p) + (page-format page "~%//") + (page-format page "~%//]]>"))) (setf (page-lasttag page) nil) (tag-render-endtag htscript page)) (when (null previous-print-status) @@ -932,9 +927,9 @@ (htcomponent-json-print-start-component htlink)) (when (page-can-print page) (unless (getf (htcomponent-attributes htlink) :type) - (append '(:type "text/css") (htcomponent-attributes htlink))) + (append '(:type "text/css") (htcomponent-attributes htlink))) (unless (getf (htcomponent-attributes htlink) :rel) - (append '(:rel "styleshhet") (htcomponent-attributes htlink))) + (append '(:rel "styleshhet") (htcomponent-attributes htlink))) (tag-render-starttag htlink page) (tag-render-endtag htlink page)) (when (null previous-print-status) @@ -944,109 +939,105 @@ ;;;========= HTBODY =================================== (defmethod htcomponent-render ((htbody htbody) (page page)) (let ((body-list (htcomponent-body htbody)) - (previous-print-status (page-can-print page))) - (when (or (page-can-print page) previous-print-status) + (previous-print-status (page-can-print page))) + (when (or (page-can-print page) previous-print-status) (setf (page-can-print page) (htcomponent-can-print htbody)) (htcomponent-json-print-start-component htbody)) (when (page-can-print page) (tag-render-starttag htbody page)) (dolist (child-tag body-list) (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (when (page-can-print page) (htcomponent-render (htbody-init-scripts-tag page) page) (tag-render-endtag htbody page)) (when (or (page-can-print page) previous-print-status) (setf (page-can-print page) nil) (htcomponent-json-print-end-component htbody)))) - + (defmethod htbody-init-scripts-tag ((page page)) (let ((js (script> :type "text/javascript")) - (js-start-directive (if (msie-p) - "window.attachEvent\('onload', function\(e) {" - "document.addEventListener\('DOMContentLoaded', function\(e) {")) - (js-end-directive (if (msie-p) - "});" - "}, false);")) - (page-body-init-scripts (page-body-init-scripts page))) + (js-start-directive (if (msie-p) + "window.attachEvent\('onload', function\(e) {" + "document.addEventListener\('DOMContentLoaded', function\(e) {")) + (js-end-directive (if (msie-p) + "});" + "}, false);")) + (page-body-init-scripts (page-body-init-scripts page))) (setf (htcomponent-page js) page - (htcomponent-body js) (when page-body-init-scripts - (if (listp page-body-init-scripts) - (append (list js-start-directive) - page-body-init-scripts - (list js-end-directive)) - (list js-start-directive page-body-init-scripts js-end-directive)))) + (htcomponent-body js) (when page-body-init-scripts + (if (listp page-body-init-scripts) + (append (list js-start-directive) + page-body-init-scripts + (list js-end-directive)) + (list js-start-directive page-body-init-scripts js-end-directive)))) js)) ;;;========= WCOMPONENT =================================== (defclass wcomponent (htcomponent) ((reserved-parameters :initarg :reserved-parameters - :accessor wcomponent-reserved-parameters - :type cons - :documentation "Parameters that may not be used in the constructor function") - (informal-parameters :initarg :informal-parameters - :accessor wcomponent-informal-parameters - :type cons - :documentation "Informal parameters are parameters optional for the component") + :accessor wcomponent-reserved-parameters + :type cons + :documentation "Parameters that may not be used in the constructor function") + (informal-parameters :initform () + :accessor wcomponent-informal-parameters + :type cons + :documentation "Informal parameters are parameters optional for the component") (allow-informal-parameters :initarg :allow-informal-parameters - :reader wcomponent-allow-informal-parametersp - :allocation :class - :documentation "Determines if the component accepts informal parameters")) - (:default-initargs :informal-parameters nil - :reserved-parameters nil + :reader wcomponent-allow-informal-parametersp + :allocation :class + :documentation "Determines if the component accepts informal parameters")) + (:default-initargs :reserved-parameters nil :allow-informal-parameters t) (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) -(defmethod wcomponent-informal-parameters ((wcomponent wcomponent))) - (defun slot-initarg-p (initarg class-precedence-list) "Returns nil if a slot with that initarg isn't found into the list of classes passed" (loop for class in class-precedence-list - do (let* ((direct-slots (closer-mop:class-direct-slots class)) - (result (loop for slot in direct-slots - do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) - (return initarg))))) - (when result - (return result))))) + do (let* ((direct-slots (closer-mop:class-direct-slots class)) + (result (loop for slot in direct-slots + do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) + (return initarg))))) + (when result + (return result))))) (defmethod initialize-instance :after ((instance wcomponent) &rest rest) (let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance))) - (informal-parameters (loop for (k v) on rest by #'cddr - for result = () - do (unless (slot-initarg-p k class-precedence-list) - (push v result) - (push k result)) - finally (return result)))) + (informal-parameters (loop for (k v) on rest by #'cddr + for result = () + do (unless (slot-initarg-p k class-precedence-list) + (push v result) + (push k result)) + finally (return result)))) (setf (slot-value instance 'informal-parameters) informal-parameters))) (defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg) (let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg)) - (new-value (if (eq slot-initarg :id) (generate-id value) value)) - (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) - do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) - (return (closer-mop:slot-definition-name slot-definition)))))) + (new-value (if (eq slot-initarg :id) (generate-id value) value)) + (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) + do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) + (return (closer-mop:slot-definition-name slot-definition)))))) (if (find initarg (wcomponent-reserved-parameters wcomponent)) - (error (format nil "Parameter ~a is reserved" initarg)) - (if slot-name - (setf (slot-value wcomponent slot-name) new-value) - (if (null (wcomponent-allow-informal-parametersp wcomponent)) - (error (format nil - "Component ~a doesn't accept informal parameters" - slot-initarg)) - (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) - - + (error (format nil "Parameter ~a is reserved" initarg)) + (if slot-name + (setf (slot-value wcomponent slot-name) new-value) + (if (null (wcomponent-allow-informal-parametersp wcomponent)) + (error (format nil + "Component ~a doesn't accept informal parameters" + slot-initarg)) + (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) + (defun make-component (name parameters content) "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content." (let ((instance (make-instance name)) - (static-id (getf parameters :static-id))) + (static-id (getf parameters :static-id))) (when static-id - (remf parameters :id)) + (remf parameters :id)) (loop for (initarg value) on parameters by #'cddr do (setf (slot-initialization instance initarg) value)) (setf (htcomponent-body instance) content) @@ -1063,9 +1054,9 @@ (let ((template (wcomponent-template wcomponent))) (wcomponent-before-rewind wcomponent page) (if (listp template) - (dolist (tag template) - (htcomponent-rewind tag page)) - (htcomponent-rewind template page)) + (dolist (tag template) + (htcomponent-rewind tag page)) + (htcomponent-rewind template page)) (wcomponent-after-rewind wcomponent page))) (defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page))) @@ -1074,23 +1065,23 @@ (defmethod htcomponent-prerender ((wcomponent wcomponent) (page page)) (wcomponent-before-prerender wcomponent page) (let ((previous-print-status (page-can-print page)) - (template (wcomponent-template wcomponent))) + (template (wcomponent-template wcomponent))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print wcomponent))) (when (page-can-print page) (dolist (script (htcomponent-script-files wcomponent)) - (pushnew script (page-script-files page) :test #'equal)) + (pushnew script (page-script-files page) :test #'equal)) (dolist (css (htcomponent-stylesheet-files wcomponent)) - (pushnew css (page-stylesheet-files page) :test #'equal)) + (pushnew css (page-stylesheet-files page) :test #'equal)) (dolist (js (htcomponent-class-initscripts wcomponent)) - (pushnew js (page-class-initscripts page) :test #'equal)) + (pushnew js (page-class-initscripts page) :test #'equal)) (when (htcomponent-instance-initscript wcomponent) - (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) + (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) (if (listp template) - (dolist (tag template) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) - (htcomponent-prerender template page)) + (dolist (tag template) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag page))) + (htcomponent-prerender template page)) (when (null previous-print-status) (setf (page-can-print page) nil))) (wcomponent-after-prerender wcomponent page)) @@ -1100,19 +1091,19 @@ (defmethod htcomponent-render ((wcomponent wcomponent) (page page)) (let ((template (wcomponent-template wcomponent)) - (previous-print-status (page-can-print page))) + (previous-print-status (page-can-print page))) (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print wcomponent)) (htcomponent-json-print-start-component wcomponent)) (wcomponent-before-render wcomponent page) (unless (listp template) (setf template (list template))) - (dolist (child-tag template) + (dolist (child-tag template) (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) (wcomponent-after-render wcomponent page) (when (null previous-print-status) (setf (page-can-print page) nil) @@ -1127,12 +1118,12 @@ (defmethod message-dispatch ((i18n-aware i18n-aware) key locale) (let ((dispatcher (message-dispatcher i18n-aware)) - (result)) + (result)) (when dispatcher (progn - (setf result (message-dispatch dispatcher key locale)) - (when (and (null result) (> (length locale) 2)) - (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) + (setf result (message-dispatch dispatcher key locale)) + (when (and (null result) (> (length locale) 2)) + (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) result)) (defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value) From achiumenti at common-lisp.net Tue May 13 13:32:44 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Tue, 13 May 2008 09:32:44 -0400 (EDT) Subject: [claw-cvs] r46 - in trunk/main/claw-core: src tests Message-ID: <20080513133244.318DB12064@common-lisp.net> 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" - "\"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]")))) + "\"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") From achiumenti at common-lisp.net Tue May 13 15:23:32 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Tue, 13 May 2008 11:23:32 -0400 (EDT) Subject: [claw-cvs] r47 - trunk/main/claw-core/src Message-ID: <20080513152332.637704D043@common-lisp.net> Author: achiumenti Date: Tue May 13 11:23:32 2008 New Revision: 47 Modified: trunk/main/claw-core/src/lisplet.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 11:23:32 2008 @@ -264,16 +264,16 @@ ;(when (lisplet-redirect-protected-resources-p lisplet) ;(redirect-to-https server request)) (cond + ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) + (setf (return-code) +http-forbidden+) + (throw 'handler-done nil)) ((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)) + (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)))))))) From achiumenti at common-lisp.net Sat May 24 17:18:44 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Sat, 24 May 2008 13:18:44 -0400 (EDT) Subject: [claw-cvs] r48 - in trunk/main/claw-core: . src Message-ID: <20080524171844.25FDC4206D@common-lisp.net> Author: achiumenti Date: Sat May 24 13:18:39 2008 New Revision: 48 Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/components.lisp 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/src/validators.lisp Log: a lot of bug fixes Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Sat May 24 13:18:39 2008 @@ -31,7 +31,7 @@ :name "claw" :author "Andrea Chiumenti" :description "Common Lisp Active Web.A famework to write web applications" - :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) + :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :parenscript) :components ((:module src :components ((:file "packages") (:file "misc" :depends-on ("packages")) Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Sat May 24 13:18:39 2008 @@ -55,7 +55,8 @@ (defun component-validation-errors (component &optional (request *request*)) "Resurns possible validation errors occurred during form rewinding bound to a specific component" (let ((client-id (htcomponent-client-id component))) - (assoc client-id (validation-errors request) :test #'equal))) + (getf (validation-errors request) (make-symbol client-id)))) + ;-------------------------------------------------------------------------------- (defclass cform (wcomponent) @@ -87,7 +88,7 @@ (defmethod wcomponent-template((cform cform)) (let ((client-id (htcomponent-client-id cform)) (class (css-class cform)) - (validation-errors (aux-request-value :validation-errors))) + (validation-errors (validation-errors))) (when validation-errors (if (or (null class) (string= class "")) (setf class "error") @@ -105,7 +106,7 @@ (setf (page-current-form pobj) obj)) (defmethod wcomponent-after-rewind ((obj cform) (pobj page)) - (let ((validation-errors (aux-request-value :validation-errors)) + (let ((validation-errors (validation-errors)) (action (action obj))) (unless validation-errors (when (or action (cform-rewinding-p obj pobj)) @@ -177,7 +178,7 @@ :reader input-type :documentation "The html TYPE attribute. For submit type, use the CSUBMIT> function.")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name) :empty t) + (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'cinput))) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Sat May 24 13:18:39 2008 @@ -196,8 +196,14 @@ (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)))))) + (length (lisplet-base-path lisplet)) + (length location) 1))) resource-path))) + (log-message :info "--------------------------------------------- ~% +script-name: \"~a\"~% +resource-path: \"~a\"~% +resource-full-path :\"~a\"~% +--------------------------------------------" (script-name) resource-path resource-full-path) (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) @@ -208,10 +214,9 @@ (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))))))) + do (progn + (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url)) + (when (starts-with-subseq rel-script-name url) (return (funcall action))))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Sat May 24 13:18:39 2008 @@ -217,6 +217,22 @@ "Resurns possible validation errors occurred during form rewinding" (aux-request-value :validation-errors request)) +(defun (setf validation-errors) (value &optional (request *request*)) + "Sets possible validation errors occurred during form rewinding" + (setf (aux-request-value :validation-errors request) value)) + +(defun validation-compliances (&optional (request *request*)) + "Resurns the list of components that pass validation during form rewinding" + (aux-request-value :validation-compliances request)) + +(defun (setf validation-compliances) (value &optional (request *request*)) + "Sets the list of components that pass validation during form rewinding" + (setf (aux-request-value :validation-compliances request) value)) + +(defun add-validation-compliance (id &optional (request *request*)) + "Adds a component id to the list of components that pass validation during form rewinding" + (setf (validation-compliances request) (nconc (validation-compliances request) (list id)))) + (defclass metacomponent (standard-class) () (:documentation "This is the meta class the must be set for every WCOMPONENT. Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Sat May 24 13:18:39 2008 @@ -211,6 +211,7 @@ :lisplet-protect :lisplet-authentication-type :claw-start-session + :build-lisplet-location ;; clawserver :clawserver :clawserver-base-path @@ -234,6 +235,8 @@ #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password + :add-exception + :component-exceptions :msie-p :*id-and-static-id-description* :describe-component-behaviour @@ -273,6 +276,8 @@ :*locales* :validate :validation-errors + :validation-compliances + :add-validation-compliance :component-validation-errors :validate-required :validate-size Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Sat May 24 13:18:39 2008 @@ -385,21 +385,15 @@ (when (starts-with-subseq script-name base-path) (setf rel-script-name (subseq script-name (length base-path)) rel-script-name-libs (subseq script-name (1+ (length base-path)))) - (or + (or (loop for dispatcher in *claw-libraries-resources* for url = (car dispatcher) for action = (cdr dispatcher) - do (cond - ((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))))) + do (when (starts-with-subseq rel-script-name-libs url) (funcall action))) (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))))))))) + do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))) (defmethod clawserver-dispatch-method ((clawserver clawserver)) (let ((result (clawserver-dispatch-request clawserver))) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Sat May 24 13:18:39 2008 @@ -15,7 +15,7 @@ ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSEDse +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY @@ -105,9 +105,10 @@ This internal method is called to render these scripts. - PAGE is the page instance that must be given")) -(defgeneric htbody-init-scripts-tag (page) +(defgeneric htbody-init-scripts-tag (page &optional on-load) (:documentation "Encloses the init inscance scripts injected into the page into a