[claw-cvs] r73 - in trunk/main/claw: . src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Tue Aug 26 10:59:27 UTC 2008
Author: achiumenti
Date: Tue Aug 26 06:59:27 2008
New Revision: 73
Modified:
trunk/main/claw/claw.asd
trunk/main/claw/src/auth.lisp
trunk/main/claw/src/lisplet.lisp
trunk/main/claw/src/misc.lisp
trunk/main/claw/src/packages.lisp
trunk/main/claw/src/server.lisp
Log:
CLAW application server
Modified: trunk/main/claw/claw.asd
==============================================================================
--- trunk/main/claw/claw.asd (original)
+++ trunk/main/claw/claw.asd Tue Aug 26 06:59:27 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 :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :bordeaux-threads :md5)
+ :depends-on (:closer-mop :cl-ppcre :cl-fad :alexandria :local-time :split-sequence :bordeaux-threads :md5)
:components ((:module src
:components ((:file "packages")
(:file "mime-type" :depends-on ("packages"))
Modified: trunk/main/claw/src/auth.lisp
==============================================================================
--- trunk/main/claw/src/auth.lisp (original)
+++ trunk/main/claw/src/auth.lisp Tue Aug 26 06:59:27 2008
@@ -57,4 +57,5 @@
(defun login ()
"Performs user authentication for the reaml where the request has been created"
(let* ((login-config (gethash *claw-current-realm* (clawserver-login-config *clawserver*))))
- (configuration-login login-config)))
\ No newline at end of file
+ (when (and login-config (null (current-principal)))
+ (setf (current-principal) (configuration-login login-config)))))
\ No newline at end of file
Modified: trunk/main/claw/src/lisplet.lisp
==============================================================================
--- trunk/main/claw/src/lisplet.lisp (original)
+++ trunk/main/claw/src/lisplet.lisp Tue Aug 26 06:59:27 2008
@@ -125,6 +125,8 @@
(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet))
(let ((lisplets (clawserver-lisplets clawserver))
(location (lisplet-base-path lisplet)))
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
(setf (clawserver-lisplets clawserver) (sort-by-location (pushnew-location
(cons location
lisplet)
@@ -133,6 +135,8 @@
(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet))
(let ((lisplets (clawserver-lisplets clawserver))
(location (lisplet-base-path lisplet)))
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
(remove-by-location location lisplets)))
@@ -146,6 +150,8 @@
:basic))
(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p)
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
(let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
(sort-by-location (pushnew-location (cons location function) pages)))
@@ -155,6 +161,8 @@
(setf (lisplet-login-page lisplet) location))))
(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type)
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
(let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
(sort-by-location (pushnew-location
@@ -165,7 +173,7 @@
(uri-to-pathname (subseq (claw-script-name)
(+ (length (clawserver-base-path *clawserver*))
(length (lisplet-base-path lisplet))
- (length location) 1)))
+ (length location) )))
resource-path)))
(claw-handle-static-file resource-full-path content-type)))
#'(lambda () (claw-handle-static-file resource-path content-type))))
@@ -174,11 +182,14 @@
(defmethod lisplet-dispatch-request ((lisplet lisplet) uri)
(let ((dispatchers (lisplet-pages lisplet))
- (rel-script-name (subseq uri (1+ (length (build-lisplet-location lisplet))))))
+ (rel-script-name (subseq uri (length (build-lisplet-location lisplet)))))
+ (setf (claw-return-code) +http-not-found+)
(loop for dispatcher in dispatchers
for url = (car dispatcher)
for action = (cdr dispatcher)
- do (when (starts-with-subseq rel-script-name url) (return (funcall action))))))
+ do (when (starts-with-subseq url rel-script-name)
+ (setf (claw-return-code) +http-ok+)
+ (return (funcall action))))))
(defmethod lisplet-dispatch-method ((lisplet lisplet))
(let* ((*claw-current-realm* (lisplet-realm lisplet))
@@ -232,18 +243,19 @@
(loop for protected-resource in protected-resources
for match = (format nil "~a/~a" base-path (car protected-resource))
for allowed-roles = (cdr protected-resource)
- do (when (or (starts-with-subseq match uri) (string= login-page-url uri))
- (cond
- ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
- (setf (claw-return-code) +http-forbidden+)
- (throw 'handler-done nil))
- ((and (null princp) auth-basicp)
- (setf (claw-return-code) +http-authorization-required+
- (claw-header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" *claw-current-realm*))
- (throw 'handler-done nil))
- ((and (null princp) (null auth-basicp) (not (string= login-page-url uri)))
- (redirect-to-https login-page-url)
- (throw 'handler-done nil))
- ((and sslport (not (= (claw-server-port) sslport)))
- (redirect-to-https)
- (throw 'handler-done nil))))))))
+ do
+ (when (or (starts-with-subseq match uri) (string= login-page-url uri))
+ (cond
+ ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
+ (setf (claw-return-code) +http-forbidden+)
+ (throw 'handler-done nil))
+ ((and (null princp) auth-basicp)
+ (setf (claw-return-code) +http-authorization-required+
+ (claw-header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" *claw-current-realm*))
+ (throw 'handler-done nil))
+ ((and (null princp) (null auth-basicp) (not (string= login-page-url uri)))
+ (redirect-to-https login-page-url)
+ (throw 'handler-done nil))
+ ((and sslport (not (= (claw-server-port) sslport)))
+ (redirect-to-https)
+ (throw 'handler-done nil))))))))
Modified: trunk/main/claw/src/misc.lisp
==============================================================================
--- trunk/main/claw/src/misc.lisp (original)
+++ trunk/main/claw/src/misc.lisp Tue Aug 26 06:59:27 2008
@@ -415,7 +415,7 @@
"Detects if current principal belongs to any of the expressed roles"
(let ((principal (current-principal)))
(when principal
- (loop for el in (principal-roles principal) thereis (member el roles)))))
+ (loop for el in (principal-roles principal) thereis (member el roles :test #'string-equal)))))
(defun current-config ()
"Returns the current configuration object for the realm of the request"
@@ -495,6 +495,8 @@
(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."
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
(setf *claw-libraries-resources*
(sort-by-location (pushnew-location
(cons location
Modified: trunk/main/claw/src/packages.lisp
==============================================================================
--- trunk/main/claw/src/packages.lisp (original)
+++ trunk/main/claw/src/packages.lisp Tue Aug 26 06:59:27 2008
@@ -31,8 +31,9 @@
(defpackage :claw
- (:use :cl :closer-mop :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :bordeaux-threads :md5)
+ (:use :cl :closer-mop :alexandria :cl-ppcre :local-time :split-sequence :bordeaux-threads :md5)
(:shadow :flatten)
+ (:import-from :cl-fad :directory-pathname-p)
(:documentation "A comprehensive web application framework and server for the Common Lisp programming language")
(:export #:*clawserver-base-path*
#:*apache-http-port*
@@ -135,15 +136,10 @@
#:session-manager
#:default-session-manager
-
- #:error-page
- #:error-page-renderer
+ #:error-renderer
#:mime-type
#:duplicate-back-slashes
-
- #:make-page-renderer
-
#:lisplet
#:lisplet-log-manager
#:lisplet-server-addrss
Modified: trunk/main/claw/src/server.lisp
==============================================================================
--- trunk/main/claw/src/server.lisp (original)
+++ trunk/main/claw/src/server.lisp Tue Aug 26 06:59:27 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.
@@ -30,7 +30,7 @@
(in-package :claw)
;;------------------------------------------------------------------------------------------
-(defgeneric error-page-renderer (clawserver &key error-code)
+(defgeneric error-renderer (clawserver &key error-code)
(:documentation "Method for rendering http errors. This method should be overridden."))
(defgeneric clawserver-host (clawserver)
@@ -41,11 +41,11 @@
(:documentation "Returns the request method as a keyword, i.e. something like :POST. \(This corresponds to the environment variable REQUEST_METHOD in CGI scripts.)"))
(defgeneric clawserver-request-uri (clawserver)
- (:documentation "Returns the URI for request.
+ (:documentation "Returns the URI for request.
Note that this not the full URI but only the part behind the scheme and authority components, so that if the user has typed http://user:password@www.domain.com/xxx/frob.html?foo=bar into his browser, this function will return \"/xxx/frob.html?foo=bar\". \(This corresponds to the environment variable REQUEST_URI in CGI scripts."))
(defgeneric clawserver-script-name (connector)
- (:documentation "Returns the file name \(or path) component of the URI for request, i.e. the part of the string returned by REQUEST-URI in front of the first question mark \(if any).
+ (:documentation "Returns the file name \(or path) component of the URI for request, i.e. the part of the string returned by REQUEST-URI in front of the first question mark \(if any).
\(This corresponds to the environment variable SCRIPT_NAME in CGI scripts.)"))
(defgeneric clawserver-query-string (clawserver)
@@ -61,14 +61,14 @@
The elements of this list are in the same order as they were within the request URI. See also CLAWSERVER-GET-PARAMETER."))
(defgeneric clawserver-post-parameter (clawserver name)
- (:documentation "Returns the value of the POST parameter \(as provided in the request's body) named by the string name.
-Note that only the first value will be returned if the client provided more than one POST parameter with the name name.
+ (:documentation "Returns the value of the POST parameter \(as provided in the request's body) named by the string name.
+Note that only the first value will be returned if the client provided more than one POST parameter with the name name.
This value will usually be a string \(or NIL if there ain't no POST parameter with this name).
If, however, the browser sent a file through a multipart/form-data form, the value of this function is a three-element list
\(path file-name content-type)
-where path is a pathname denoting the place were the uploaded file was stored, file-name \(a string) is the file name sent by the browser, and content-type \(also a string) is the content type sent by the browser.
+where path is a pathname denoting the place were the uploaded file was stored, file-name \(a string) is the file name sent by the browser, and content-type \(also a string) is the content type sent by the browser.
The file denoted by path will be deleted after the request has been handled - you have to move or copy it somewhere else if you want to keep it."))
(defgeneric clawserver-post-parameters (clawserver)
@@ -80,7 +80,7 @@
If both a GET and a POST parameter with the name name exist, the GET parameter will be returned. See also CLAWSERVER-GET-PARAMETER and CLAWSERVER-POST-PARAMETER."))
(defgeneric clawserver-header-in (clawserver name)
- (:documentation "Returns the incoming header named by the keyword name as a string \(or NIL if there ain't no header with this name).
+ (:documentation "Returns the incoming header named by the keyword name as a string \(or NIL if there ain't no header with this name).
Note that this queries the headers sent to Hunchentoot by the client or by mod_lisp. In the latter case this may not only include the incoming http headers but also some headers sent by mod_lisp.
For backwards compatibility, name can also be a string which is matched case-insensitively. See also CLAWSERVER-HEADERS-IN."))
@@ -100,7 +100,7 @@
(:documentation "Returns the IP port (as a number) of the client which sent the request."))
(defgeneric clawserver-real-remote-addr (clawserver)
- (:documentation "Returns the value of the incoming X-Forwarded-For http header as the second value in the form of a list of IP addresses and the first element of this list as the first value if this header exists.
+ (:documentation "Returns the value of the incoming X-Forwarded-For http header as the second value in the form of a list of IP addresses and the first element of this list as the first value if this header exists.
Otherwise returns the value of CLAWSERVER-REMOTE-ADDR as the only value."))
(defgeneric clawserver-server-addr (clawserver)
@@ -145,15 +145,15 @@
See also CLAWSERVER-HEADERS-OUT, CLAWSERVER-CONTENT-TYPE, CLAWSERVER-CONTENT-LENGTH, CLAWSERVER-COOKIES-OUT, and CLAWSERVER-COOKIE-OUT"))
(defgeneric (setf clawserver-header-out) (value clawserver name)
- (:documentation "SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol).
-If no header named name exists it is created.
-Note that the headers Set-Cookie, Content-Length, and Content-Type must not be set by SETF of HEADER-OUT.
+ (:documentation "SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol).
+If no header named name exists it is created.
+Note that the headers Set-Cookie, Content-Length, and Content-Type must not be set by SETF of HEADER-OUT.
Also, there are a couple of \"technical\" headers like Connection or Transfer-Encoding that you're not supposed to set yourself.
See also CLAWSERVER-HEADERS-OUT, CLAWSERVER-CONTENT-TYPE, CLAWSERVER-CONTENT-LENGTH, CLAWSERVER-COOKIES-OUT, and CLAWSERVER-COOKIE-OUT"))
(defgeneric clawserver-headers-out (clawserver)
(:documentation "Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type).
-The car of each element of this list is the headers's name while the cdr is its value.
+The car of each element of this list is the headers's name while the cdr is its value.
This alist should not be manipulated directly, use SETF of CLAWSERVER-HEADER-OUT instead"))
(defgeneric clawserver-cookie-out (clawserver name)
@@ -296,53 +296,58 @@
(script-name (connector-script-name connector))
(rel-script-name)
(rel-script-name-libs)
- (http-result))
- (handler-bind ((error (lambda (cond)
- (logger-log (clawserver-log-manager clawserver) :error "~a" cond)
- (with-output-to-string (*standard-output*)
- (error-page-renderer clawserver :error-code +http-internal-server-error+)))))
- (unwind-protect
- (catch 'handler-done
- (if (starts-with-subseq script-name base-path)
- (progn
- (setf rel-script-name (subseq script-name (length base-path))
- rel-script-name-libs (subseq script-name (1+ (length base-path))))
- (setf http-result (or
- (loop for dispatcher in *claw-libraries-resources*
- for url = (car dispatcher)
- for action = (cdr dispatcher)
- do (when (starts-with-subseq rel-script-name-libs url) (funcall action)))
- (loop for lisplet-cons in lisplets
- for url = (car lisplet-cons)
- for lisplet = (cdr lisplet-cons)
- do (when (starts-with-subseq rel-script-name url) (return (funcall #'lisplet-dispatch-method lisplet))))))))))
- (or http-result
- (let ((error-handler (and *claw-current-lisplet*
- (gethash (or
- (let ((return-code (claw-return-code)))
- (if (= return-code +http-ok+)
- nil
- return-code))
- +http-not-found+)
- (lisplet-error-handlers *claw-current-lisplet*)))))
- (when error-handler
- (funcall error-handler)))
- (with-output-to-string (*standard-output*)
- (error-page-renderer clawserver (or
- (let ((return-code (claw-return-code)))
- (if (= return-code +http-ok+)
- nil
- return-code))
- +http-not-found+)))))))
+ (http-result nil))
+ (handler-case
+ (progn
+ (unwind-protect
+ (catch 'handler-done
+ (progn
+ (setf (claw-return-code) +http-not-found+)
+ (if (starts-with-subseq base-path script-name)
+ (progn
+ (setf rel-script-name (subseq script-name (length base-path))
+ rel-script-name-libs (subseq script-name (length base-path)))
+ (setf http-result (or
+ (loop for dispatcher in *claw-libraries-resources*
+ for url = (car dispatcher)
+ for action = (cdr dispatcher)
+ do (when (starts-with-subseq url rel-script-name-libs)
+ (setf (claw-return-code) +http-ok+)
+ (funcall action)))
+ (loop for lisplet-cons in lisplets
+ for url = (car lisplet-cons)
+ for lisplet = (cdr lisplet-cons)
+ do (when (starts-with-subseq url rel-script-name)
+ (setf (claw-return-code) +http-ok+)
+ (return (funcall #'lisplet-dispatch-method lisplet)))))))))))
+ (or http-result
+ (and (>= (claw-return-code) 400)
+ (or
+ (let ((error-handler (and *claw-current-lisplet*
+ (gethash (or
+ (let ((return-code (claw-return-code)))
+ (if (= return-code +http-ok+)
+ nil
+ return-code))
+ +http-not-found+)
+ (lisplet-error-handlers *claw-current-lisplet*)))))
+ (when error-handler
+ (funcall error-handler)))
+ (with-output-to-string (*standard-output*)
+ (error-renderer clawserver :error-code (or
+ (let ((return-code (claw-return-code)))
+ (if (= return-code +http-ok+)
+ nil
+ return-code))
+ +http-not-found+)))))
+ ))
+ (error (cond)
+ (logger-log (clawserver-log-manager clawserver) :error "~a" cond)
+ (with-output-to-string (*standard-output*) (error-renderer clawserver :error-code +http-internal-server-error+))))))
(defmethod clawserver-dispatch-method ((clawserver clawserver))
- (let ((result (clawserver-dispatch-request clawserver))
- (connector (clawserver-connector clawserver)))
- (if (null result)
- #'(lambda () (when (= (connector-return-code connector) 200) ;OK
- (setf (connector-return-code connector) 404))) ; Not found
- #'(lambda () result))))
+ #'(lambda () (clawserver-dispatch-request clawserver)))
(defmethod clawserver-start ((clawserver clawserver))
(let ((*clawserver* clawserver)
@@ -511,13 +516,63 @@
(defmethod clawserver-script-name ((clawserver clawserver))
(connector-script-name (clawserver-connector clawserver)))
-(defmethod error-page-renderer ((clawserver clawserver) &key (error-code 404))
- (format nil "<html>
+(defmethod error-renderer ((clawserver clawserver) &key (error-code 404))
+ (let ((request-uri (connector-request-uri (clawserver-connector clawserver)))
+ (connector (clawserver-connector clawserver))
+ (style "body {
+ font-family: arial, elvetica;
+ font-size: 7pt;
+}
+span.blue {
+ padding: 0 3px;
+ background-color: #525D76;
+ color: white;
+ font-weight: bolder;
+ margin-right: .25em;
+}
+p.h1, p.h2 {
+ padding: 0 3px;
+ background-color: #525D76;
+ color: white;
+ font-weight: bolder;
+ font-size: 2em;
+ margin: 0;
+ margin-bottom: .5em;
+}
+p.h2 {font-size: 1.5em;}"))
+ (setf (connector-return-code connector) error-code)
+ (format t "<html>
<head>
<title>Error ~a</title>
+ <style>~a</style>
</head>
<body>
-<h1>HTTP Status ~a</h1>
-<h2>~a</h2>
+ <p>
+ <p class='h1'>
+ HTTP Status ~a - ~a
+ </p>
+ <hr noshade='noshade'>
+ <p>
+ <span class='blue'>type</span>
+ Status report
+ </p>
+ <p>
+ <span class='blue'>url</span>
+ ~a
+ </p>
+ <p>
+ <span class='blue'>description</span>
+ ~a
+ </p>
+ <hr noshade='noshade'>
+ <p class='h2'>
+ CLAW server
+ </p>
+ </p>
</body>
-</html>" error-code error-code (gethash error-code *http-reason-phrase-map*)))
\ No newline at end of file
+</html>"
+ error-code ;title
+ style ;tyle
+ error-code request-uri
+ request-uri
+ (gethash error-code *http-reason-phrase-map*))))
\ No newline at end of file
More information about the Claw-cvs
mailing list