[claw-cvs] r9 - in trunk/main/claw-core: src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Fri Feb 15 15:12:47 UTC 2008
Author: achiumenti
Date: Fri Feb 15 10:12:46 2008
New Revision: 9
Modified:
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
added some documentation
added lisplet error hanlders logic
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Fri Feb 15 10:12:46 2008
@@ -29,47 +29,110 @@
(in-package :claw)
-;(print *this-file*)
-
-(defgeneric lisplet-register-function-location (obj function location &key welcome-pagep login-pagep))
-(defgeneric lisplet-register-page-location (obj page-class location &key welcome-pagep login-pagep))
-
-(defgeneric lisplet-register-resource-location (obj uri url &optional content-type))
-
-(defgeneric lisplet-dispatch-request (obj))
-(defgeneric lisplet-dispatch-method (obj))
-(defgeneric lisplet-protect (lisplet location roles))
-(defgeneric lisplet-check-authorization (lisplet &optional request))
-(defgeneric lisplet-authentication-type (lisplet))
+(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:
+- LISPLET the lisplet that will dispatch the function
+- FUNCTION the function to register for dispatching
+- LOCATION The url location where the function will be registered (relative to the lisplet base path)
+keys:
+- :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
+- :LOGIN-PAGE-P Marks the function as a login page"))
+
+(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p)
+ (:documentation "Registers a page into a lisplet for dispatching.
+parameters:
+- LISPLET the lisplet that will dispatch the page
+- PAGE-CLASS symbol name of the page that is to be registerd for dispatching
+- LOCATION The url location where the page will be registered (relative to the lisplet base path)
+keys:
+- :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
+- :LOGIN-PAGE-P Marks the page as a login page"))
+
+(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type)
+ (:documentation "Registers a resource (file or directory) into a lisplet for dispatching.
+parameters:
+- LISPLET the lisplet that will dispatch the page
+- RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching
+- LOCATION The url location where the resource will be registered (relative to the lisplet base path)
+- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type"))
+
+(defgeneric lisplet-dispatch-method (lisplet)
+ (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST
+- LISPLET the lisplet object"))
+
+(defgeneric lisplet-dispatch-request (lisplet)
+ (:documentation "Dispatches the http request.
+- LISPLET the lisplet object"))
+
+(defgeneric lisplet-protect (lisplet location roles)
+ (:documentation "protects all the resources that start with the given LOCATION, making them available only if the
+user is logged and belongs at least to one of the given roles.
+parameters:
+- LISPLET the lisplet object.
+- LOCATION the location that must be protected.
+- ROLES a string list containing all the roles allowed to acces the given location."))
+
+(defgeneric lisplet-check-authorization (lisplet &optional request)
+ (:documentation "Performs authentication and authorization checking.
+Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the
+lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login."))
+
+(defgeneric lisplet-authentication-type (lisplet)
+ (:documentation "When there is no page or function registered into the lisplet as login page returns :BASIC, otherwise returns :FORM.
+parameters:
+- LISPLET the lisplet object."))
(setf *http-error-handler*
+ ;;overrides the default hunchentoot error handling
#'(lambda (error-code)
- (let ((error-page (make-instance 'error-page
- :title (format nil "Server error: ~a" error-code)
- :error-code error-code)))
- (with-output-to-string (*standard-output*) (page-render error-page)))))
+ (let* ((error-handlers (current-lisplet))
+ (handler (gethash error-code error-handlers)))
+ (if handler
+ (funcall handler)
+ (let ((error-page (make-instance 'error-page
+ :title (format nil "Server error: ~a" error-code)
+ :error-code error-code)))
+ (with-output-to-string (*standard-output*) (page-render error-page)))))))
+
+(defun lisplet-start-session ()
+ "Starts a session boud to the current lisplet base path"
+ (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet)))))
(defclass lisplet ()
((base-path :initarg :base-path
- :reader lisplet-base-path)
+ :reader lisplet-base-path
+ :documentation "common base path all resources registered into this lisplet")
(welcome-page :initarg :welcome-page
- :accessor lisplet-welcome-page)
+ :accessor lisplet-welcome-page
+ :documentation "url location for the welcome page")
(login-page :initarg :login-page
- :accessor lisplet-login-page)
+ :accessor lisplet-login-page
+ :documentation "url location for the welcome page")
(realm :initarg :realm
- :reader lisplet-realm)
+ :reader lisplet-realm
+ :documentation "realm for requests that pass through this lisplet and session opened into this lisplet")
(pages :initform nil
- :accessor lisplet-pages)
+ :accessor lisplet-pages
+ :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher")
+ (error-handlers :initform (make-hash-table)
+ :accessor lisplet-error-hadlers
+ :documentation "An hash table where keys are http error codes and values are functions with no parameters")
(protected-resources :initform nil
- :accessor lisplet-protected-resources)
+ :accessor lisplet-protected-resources
+ :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location")
(redirect-protected-resources-p :initarg :redirect-protected-resources-p
- :accessor lisplet-redirect-protected-resources-p))
+ :accessor lisplet-redirect-protected-resources-p
+ :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used"))
(:default-initargs :welcome-page nil
:login-page nil
:realm "claw"
- :redirect-protected-resources-p nil))
+ :redirect-protected-resources-p nil)
+ (: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)
+ "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
@@ -84,36 +147,36 @@
:form
:basic))
-(defmethod lisplet-register-function-location ((obj lisplet) function location &key welcome-pagep login-pagep)
- (let ((pages (lisplet-pages obj))
- (new-location (build-lisplet-location obj location)))
- (setf (lisplet-pages obj)
+(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)))
+ (setf (lisplet-pages lisplet)
(sort-dispatchers (push-location-cons
(cons new-location
(create-prefix-dispatcher new-location
function
- (lisplet-realm obj)))
+ (lisplet-realm lisplet)))
pages)))
- (when welcome-pagep
- (setf (lisplet-welcome-page obj) new-location))
- (when login-pagep
- (setf (lisplet-login-page obj) new-location))))
-
-(defmethod lisplet-register-page-location ((obj lisplet) page-class location &key welcome-pagep login-pagep)
- (let ((new-location (build-lisplet-location obj location)))
- (lisplet-register-function-location obj
+ (when welcome-page-p
+ (setf (lisplet-welcome-page lisplet) new-location))
+ (when login-page-p
+ (setf (lisplet-login-page lisplet) new-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 obj :url new-location))))
+ (page-render (make-instance page-class :lisplet lisplet :url new-location))))
location
- :welcome-pagep welcome-pagep
- :login-pagep login-pagep)))
+ :welcome-page-p welcome-page-p
+ :login-page-p login-page-p)))
-(defmethod lisplet-register-resource-location ((obj lisplet) resource-path location &optional content-type)
- (let ((pages (lisplet-pages obj))
- (new-location (build-lisplet-location obj location)))
- (setf (lisplet-pages obj)
+(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)))
+ (setf (lisplet-pages lisplet)
(sort-dispatchers (push-location-cons
(cons new-location
(if (directory-pathname-p resource-path)
@@ -121,30 +184,28 @@
(create-static-file-dispatcher-and-handler new-location resource-path content-type)))
pages)))))
-(defmethod lisplet-dispatch-request ((obj lisplet))
- (let ((pages (lisplet-pages obj)))
+(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 (progn
- ;; handle authentication
- (funcall action)))))
+ when action return (funcall action))))
-(defmethod lisplet-dispatch-method ((obj lisplet))
+(defmethod lisplet-dispatch-method ((lisplet lisplet))
(let ((result nil)
- (base-path (build-lisplet-location obj nil))
+ (base-path (build-lisplet-location lisplet nil))
(uri (request-uri))
- (welcome-page (lisplet-welcome-page obj)))
+ (welcome-page (lisplet-welcome-page lisplet)))
(progn
- (setf (aux-request-value 'lisplet) obj)
- (setf (aux-request-value 'realm) (lisplet-realm obj))
- (lisplet-check-authorization obj)
+ (setf (aux-request-value 'lisplet) lisplet)
+ (setf (aux-request-value '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 obj))
+ (redirect (lisplet-welcome-page lisplet))
t)
(progn
- (setf result (lisplet-dispatch-request obj))
+ (setf result (lisplet-dispatch-request lisplet))
(when (null result)
(setf (return-code) +http-not-found+))
result))))))
@@ -157,7 +218,8 @@
(cons new-location roles)
protected-resources)))))
-(defun redirect-to-https (server request)
+(defun redirect-to-https (server request)
+ "Redirects a request sent through http using https"
(cond
((= (server-port request) (clawserver-port server))
(progn
@@ -204,6 +266,3 @@
(unless (user-in-role-p)
(setf (return-code) +http-forbidden+)
(throw 'handler-done nil))))))))
-
-(defun lisplet-start-session ()
- (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet)))))
\ No newline at end of file
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Fri Feb 15 10:12:46 2008
@@ -29,8 +29,10 @@
(in-package :claw)
-(defvar *apache-http-port* 80)
-(defvar *apache-https-port* 443)
+(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")
(defun strings-to-jsarray (strings)
"Transforms a list of strings into a javascript array."
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Fri Feb 15 10:12:46 2008
@@ -230,6 +230,7 @@
:lisplet-protect
:lisplet-authentication-type
:lisplet-start-session
+ :lisplet-error-handlers
:lisplet-redirect-protected-resources-p
;; clawserver
:clawserver
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Fri Feb 15 10:12:46 2008
@@ -139,7 +139,7 @@
(defun test-image-file ()
(make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg"))
-(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-pagep t)
+(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t)
(lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg")
@@ -255,7 +255,7 @@
(aux-request-value 'password) (login-page-password login-page))
(login))
-(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-pagep t)
+(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t)
(defclass form-page (page)
((name :initarg :name
More information about the Claw-cvs
mailing list