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