Changeset 73

Timestamp:

08/26/08 10:59:27 (3 months ago)

Author:

achiumenti

Message:

CLAW application server

Location:

trunk/main/claw

Files:

• claw.asd (modified) (1 diff)
• src/auth.lisp (modified) (1 diff)
• src/lisplet.lisp (modified) (7 diffs)
• src/misc.lisp (modified) (2 diffs)
• src/packages.lisp (modified) (2 diffs)
• src/server.lisp (modified) (11 diffs)

trunk/main/claw/claw.asd

@@ -32 +32 @@
   :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")

trunk/main/claw/src/auth.lisp

@@ -58 +58 @@
   "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)))
+    (when (and login-config (null (current-principal)))
+      (setf (current-principal) (configuration-login login-config)))))

trunk/main/claw/src/lisplet.lisp

@@ -126 +126 @@
   (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
@@ -134 +136 @@
   (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)))
 
@@ -147 +151 @@
 
 (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)
@@ -156 +162 @@
 
 (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)
@@ -166 +174 @@
                                                                                                (+ (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)))
@@ -175 +183 @@
 (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))
@@ -233 +244 @@
          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))))))))

trunk/main/claw/src/misc.lisp

@@ -416 +416 @@
   (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 ()
@@ -496 +496 @@
 (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

trunk/main/claw/src/packages.lisp

@@ -32 +32 @@
 
 (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*
@@ -136 +137 @@
            #:session-manager
            #:default-session-manager
-
-           #:error-page
-           #:error-page-renderer
+           #:error-renderer
 
            #:mime-type
            #:duplicate-back-slashes
-
-           #:make-page-renderer
-
            #:lisplet
            #:lisplet-log-manager

trunk/main/claw/src/server.lisp

@@ -1 @@
-;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
 ;;; $Header: src/server.lisp $
 
@@ -31 +31 @@
 
 ;;------------------------------------------------------------------------------------------
-(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."))
 
@@ -42 +42 @@
 
 (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.)"))
 
@@ -62 +62 @@
 
 (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
@@ -69 +69 @@
 \(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."))
 
@@ -81 +81 @@
 
 (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."))
@@ -101 +101 @@
 
 (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."))
 
@@ -146 +146 @@
 
 (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"))
@@ -154 +154 @@
 (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"))
 
@@ -297 +297 @@
          (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))
@@ -512 +517 @@
   (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*)))
+</html>" 
+            error-code ;title
+            style ;tyle
+            error-code request-uri
+            request-uri
+            (gethash error-code *http-reason-phrase-map*))))