Support dynamic-only virtual hosts by supplying NIL for a VHOST's ROOT.
authorMatthew Mondor <mmondor@pulsar-zone.net>
Wed, 19 Sep 2012 19:29:15 +0000 (19:29 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Wed, 19 Sep 2012 19:29:15 +0000 (19:29 +0000)
This is the default configuration for security, which is much better than
the previous "/".

mmsoftware/cl/server/httpd.lisp

index 44de8d8..61e9953 100644 (file)
@@ -1,4 +1,4 @@
-;;;; $Id: httpd.lisp,v 1.27 2012/09/19 06:08:24 mmondor Exp $
+;;;; $Id: httpd.lisp,v 1.28 2012/09/19 19:29:15 mmondor Exp $
 
 #|
 
@@ -76,8 +76,19 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;; - Logging format customization
 ;;;; - Support standalone option which will use an embedded-compiled
 ;;;;   configuration file and not allow the executable to load one
-;;;; - Support dynamic-only virtual-hosts (not needing a path for static
-;;;;   files and not supporting static transfers)
+;;;; - For dynamic-only virtual-hosts, it'd be nice if some specific static
+;;;;   files could be embedded as part of the executable to be served
+;;;;   statically.  This could be useful for self-contained applications
+;;;;   which require some CSS or a small number of images, for instance.
+;;;;   A utility could be provided to create byte vectors as a fasl under
+;;;;   wanted symbols, and a hash table of path to vector could be filed by
+;;;;   the configuration and used for lookup...  The server-startup-time
+;;;;   would be used as the modification timestamp for these "file" blobs.
+;;;; - Perhaps eventually support static linking of everything to ease
+;;;;   deployment even more.  This however might violate the LGPL license
+;;;;   which ECL uses unless also distributing the HTTPd source, but this
+;;;;   edition is already open-source, it could suffice to provide a link
+;;;;   to this source as part of the documentation or logs.
 
 
 (declaim (optimize (speed 3) (safety 1) (debug 3)))
@@ -138,7 +149,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (in-package :httpd)
 
 (defparameter *rcsid*
-  "$Id: httpd.lisp,v 1.27 2012/09/19 06:08:24 mmondor Exp $")
+  "$Id: httpd.lisp,v 1.28 2012/09/19 19:29:15 mmondor Exp $")
 
 (defparameter *server-version*
   (let ((parts (string-split *rcsid*
@@ -225,12 +236,17 @@ object with:
  VIRTUAL: The virtual ROOT-based absolute fullpath, useful to report to
           the user.
 Note that the supplied ROOT should previously have been passed through
-PATH-VALID, and that both ROOT and PATH should be absolute paths."
+PATH-VALID, and that both ROOT and PATH should be absolute paths.
+The exception is if ROOT is NIL, in which case REAL will also be NIL,
+for virtual hosts without static content."
   (let* ((virtual (path-valid (concatenate 'string "/" path)))
-        (real (if virtual (path-valid (concatenate 'string
-                                                   "/" root "/" virtual))
-                  nil)))
-    (if (and virtual real)
+        (real (if (null root)
+                  nil
+                  (if virtual (path-valid
+                               (concatenate 'string
+                                            "/" root "/" virtual))
+                      nil))))
+    (if (and virtual (or real (null root)))
        (make-path :real real
                   :virtual virtual)
        nil)))
@@ -253,7 +269,8 @@ PATH-VALID, and that both ROOT and PATH should be absolute paths."
 (defstruct vhost
   "Structure to configure/describe a virtual host."
   (hostname            ""              :type string :read-only t)
-  (root                        "/"             :type string)
+  ;; If ROOT is NIL this VHOST only supports dynamic handlers, no files.
+  (root                        nil             :type (or null string))
   (index               "/index.html"   :type string)
   (charset             :utf-8          :type keyword)
   (autoindex           nil             :type boolean)
@@ -274,8 +291,9 @@ if DEFAULT is T.  May override pre-existing vhosts and aliases."
   (with-accessors ((name vhost-hostname)
                   (root vhost-root)
                   (index vhost-index)) vhost
-    (unless (path-valid root)
-      (error "Invalid root path \"~A\"" root))
+    (when root
+      (unless (path-valid root)
+       (error "Invalid root path \"~A\"" root)))
     (unless (path-valid index)
       (error "Invalid index path \"~A\"" index))
     (mp:with-lock (*vhosts-lock*)
@@ -321,9 +339,10 @@ found."
              (t
               nil))))))
 
+(declaim (inline vhost-path))
 (defun vhost-path (vhost path)
   "Validates user-supplied PATH for VHOST, and returns a PATH object if
-valid, or NIL.  See PATH-VALID-VIRTUAL."
+valid, or NIL.  See PATH-VALID-VIRTUAL for more details."
   (path-valid-virtual (vhost-root vhost) path))
 
 ;;; VHost dynamic handlers
@@ -2038,7 +2057,11 @@ object, as well as the DEBUG-FEATURE function for more information.")
 
                 ;; Prioritize any existing dynamic handler over static
                 (unless (http-dynamic-dispatch req connection path)
-                  (http-static-dispatch req connection path)))))
+                  (if (path-real path)
+                      (http-static-dispatch req connection path)
+                      (http-error stream 404 "Not Found"
+                                  "\"~A\" could not be found."
+                                  (path-virtual path)))))))
 
         (http-reply-signal-no-keepalive ()
           (loop-finish))