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")