- Drop htdocs/favicon.ico and replace it by htdocs/crow-httpd-icon.png
authorMatthew Mondor <mmondor@pulsar-zone.net>
Thu, 27 Sep 2012 03:13:48 +0000 (03:13 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Thu, 27 Sep 2012 03:13:48 +0000 (03:13 +0000)
- Make VHOST-QUERY process VHOST designators, such that various functions
  using it may also accept a VHOST object rather than a string
- Make VHOST-REGISTER automatically register our embedded files
- Make test applications use the new shortcut icon

mmsoftware/cl/server/GNUmakefile
mmsoftware/cl/server/embedded-files.lisp
mmsoftware/cl/server/htdocs/crow-httpd-icon.png [new file with mode: 0644]
mmsoftware/cl/server/htdocs/favicon.ico [deleted file]
mmsoftware/cl/server/httpd.lisp
mmsoftware/cl/server/test-applications.lisp

index bebb913..b2f32ea 100644 (file)
@@ -12,7 +12,7 @@ BINARY := crow-httpd
 
 all: $(ARCHIVE) $(BINARY)
 
-embedded-files.fas: htdocs/crow-httpd-logo.png htdocs/crow-httpd.css htdocs/valid-xhtml.png htdocs/favicon.ico
+embedded-files.fas: htdocs/crow-httpd-logo.png htdocs/crow-httpd.css htdocs/valid-xhtml.png htdocs/crow-httpd-icon.png
 
 $(ARCHIVE): $(FASLS) $(APPLICATIONS)
        tar czvf $(ARCHIVE) $(FASLS) $(APPLICATIONS) $(CONFIGS)
index c57f6a3..0760272 100644 (file)
@@ -9,16 +9,16 @@
 (in-package :embedded-files)
 
 (defparameter *rcsid*
-  "$Id: embedded-files.lisp,v 1.2 2012/09/26 20:18:43 mmondor Exp $")
+  "$Id: embedded-files.lisp,v 1.3 2012/09/27 03:13:48 mmondor Exp $")
 
 
 (const-file-embed ((*crow-httpd-logo-png*
                    "image/png"
                    "htdocs/crow-httpd-logo.png")
 
-                  (*favicon-ico*
+                  (*crow-httpd-icon-png*
                    "image/x-icon"
-                   "htdocs/favicon.ico")
+                   "htdocs/crow-httpd-icon.png")
 
                   (*crow-httpd-css*
                    "text/css"
diff --git a/mmsoftware/cl/server/htdocs/crow-httpd-icon.png b/mmsoftware/cl/server/htdocs/crow-httpd-icon.png
new file mode 100644 (file)
index 0000000..e1a02e4
Binary files /dev/null and b/mmsoftware/cl/server/htdocs/crow-httpd-icon.png differ
diff --git a/mmsoftware/cl/server/htdocs/favicon.ico b/mmsoftware/cl/server/htdocs/favicon.ico
deleted file mode 100644 (file)
index dcaa813..0000000
Binary files a/mmsoftware/cl/server/htdocs/favicon.ico and /dev/null differ
index 9e35459..4b87d03 100644 (file)
@@ -1,4 +1,4 @@
-;;;; $Id: httpd.lisp,v 1.36 2012/09/27 02:00:51 mmondor Exp $
+;;;; $Id: httpd.lisp,v 1.37 2012/09/27 03:13:48 mmondor Exp $
 
 #|
 
@@ -99,6 +99,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;   a FILE-ERROR condition as well, or perhaps even a special error which
 ;;;;   is more friendly to errno such as C-ERROR with ERRNO and object
 ;;;;   slots... or at least END-OF-FILE.
+;;;; - Make errors use our embedded CSS and shortcut icon
+;;;; - Perhaps make VHOST creation automatically include our embedded
+;;;;   files as well
 
 
 (declaim (optimize (speed 3) (safety 1) (debug 3)))
@@ -161,7 +164,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (in-package :httpd)
 
 (defparameter *rcsid*
-  "$Id: httpd.lisp,v 1.36 2012/09/27 02:00:51 mmondor Exp $")
+  "$Id: httpd.lisp,v 1.37 2012/09/27 03:13:48 mmondor Exp $")
 
 (defparameter *server-version*
   (let ((parts (string-split *rcsid*
@@ -318,41 +321,51 @@ if DEFAULT is T.  May override pre-existing vhosts and aliases."
           do
             (setf (gethash (string-downcase alias) vhosts) vhost))
        (when default
-         (setf *vhost-default* vhost)))))
+         (setf *vhost-default* vhost))))
+    (vhost-handler-register vhost
+      '(("/images/crow-httpd-logo.png"
+        :embedded embedded-files:*crow-httpd-logo-png*)
+       ("/images/crow-httpd-icon.png"
+        :embedded embedded-files:*crow-httpd-icon-png*)
+       ("/images/valid-xhtml.png"
+        :embedded embedded-files:*valid-xhtml-png*)
+       ("/css/crow-httpd.css"
+        :embedded embedded-files:*crow-httpd-css*))))
   (values))
 
-(defun vhost-unregister (name)
-  "Looks up in the virtual hosts table any match for hostname or alias NAME
-then unregisters/deletes that VHOST if found.  Returns T if the virtual
-host was found and unregistered, or NIL if NAME did not match any."
-  (let ((found nil))
-    (mp:with-lock (*vhosts-lock*)
-      (let ((vhosts *vhosts*))
-       (multiple-value-bind (vhost exists-p)
-           (gethash (string-downcase name) vhosts)
-         (when exists-p
-           (setf found t)
-           (loop
-              for key being each hash-key of vhosts using (hash-value val)
-              when (eq val vhost) do (remhash key vhosts))))))
-    found))
-
-(defun vhost-query (name &key (default nil))
-  "Looks up in the virtual hosts table any match for hostname or alias NAME
-and returns the matching VHOST object if found, or NIL.  If DEFAULT is T,
-returns the VHOST object for the default virtual host if NAME cannot not be
-found."
+(defun vhost-query (designator &key (default nil))
+  "Looks up in the virtual hosts table any match for hostname or alias
+DESIGNATOR and returns the matching VHOST object if found, or NIL.
+ If DEFAULT is T, returns the VHOST object for the default virtual host if
+DESIGNATOR cannot not be found.  If DESIGNATOR is already a VHOST object,
+returns it."
   (declare (optimize (speed 3) (safety 0) (debug 0)))
-  (mp:with-lock (*vhosts-lock*)
-    (multiple-value-bind (vhost exists-p)
-       (gethash (string-downcase name) *vhosts*)
-      (let ((vhost-default *vhost-default*))
-       (cond ((and default vhost-default (not exists-p))
-              vhost-default)
-             (exists-p
-              vhost)
-             (t
-              nil))))))
+  (if (vhost-p designator)
+      designator
+      (mp:with-lock (*vhosts-lock*)
+       (multiple-value-bind (vhost exists-p)
+           (gethash (string-downcase designator) *vhosts*)
+         (let ((vhost-default *vhost-default*))
+           (cond ((and default vhost-default (not exists-p))
+                  vhost-default)
+                 (exists-p
+                  vhost)
+                 (t
+                  nil)))))))
+
+(defun vhost-unregister (designator)
+  "Looks up in the virtual hosts table any match for hostname or alias
+DESIGNATOR then unregisters/deletes that VHOST if found.  Returns T if the
+virtual host was found and unregistered, or NIL if DESIGNATOR did not match
+any."
+  (let ((vhost (vhost-query designator)))
+    (if vhost
+       (mp:with-lock (*vhosts-lock*)
+         (loop
+            for key being each hash-key of vhosts using (hash-value val)
+            when (eq val vhost) do (remhash key vhosts))
+         t)
+       nil)))
 
 (declaim (inline vhost-path))
 (defun vhost-path (vhost path)
@@ -362,8 +375,8 @@ valid, or NIL.  See PATH-VALID-VIRTUAL for more details."
   (path-valid-virtual (vhost-root vhost) path))
 
 ;;; Special VHost resource handlers
-(defun vhost-handler-register (vhost-name handlers)
-  "Registers the supplied HANDLERS for the VHOST matching VHOST-NAME.
+(defun vhost-handler-register (vhost-designator handlers)
+  "Registers the supplied HANDLERS for the VHOST matching VHOST-DESIGNATOR.
 HANDLERS should be a list of lists, with every sublist holding three
 items.  The first item consists of a fullpath to match, the second of a
 handler type keyword symbol and the third a parameter.  The supported
@@ -387,7 +400,7 @@ formats are as follows:
   the resource TO-PATH.
 
 Previously registered handlers for VHOST may be overridden."
-  (let ((vhost (vhost-query vhost-name)))
+  (let ((vhost (vhost-query vhost-designator)))
     (check-type vhost vhost)
     (check-type handlers list)
     (mapc #'(lambda (sublist)
@@ -419,10 +432,10 @@ Previously registered handlers for VHOST may be overridden."
          handlers))
   (values))
 
-(defun vhost-handler-list (vhost-name)
-  "Finds the VHOST object matching VHOST-NAME, and returns a list of
+(defun vhost-handler-list (vhost-designator)
+  "Finds the VHOST object matching VHOST-DESIGNATOR, and returns a list of
 previously registered handlers for that virtual host."
-  (let* ((vhost (vhost-query vhost-name))
+  (let* ((vhost (vhost-query vhost-designator))
         (list '()))
     (when vhost
       (mp:with-lock (*vhosts-lock*)
@@ -431,12 +444,12 @@ previously registered handlers for that virtual host."
                 (vhost-%handlers vhost))))
     (sort list #'string< :key #'first)))
 
-(defun vhost-handler-unregister (vhost-name handlers)
-  "Finds the the VHOST object matching VHOST-NAME, and if found,
+(defun vhost-handler-unregister (vhost-designator handlers)
+  "Finds the the VHOST object matching VHOST-DESIGNATOR, and if found,
 unregister any supplied handler in HANDLERS for that virtual host, if it
 exists.  HANDLERS should be a list of strings, each string representing
 a path."
-  (let ((vhost (vhost-query vhost-name)))
+  (let ((vhost (vhost-query vhost-designator)))
     (when (and vhost handlers)
       (mapc #'(lambda (path)
                (check-type path string)
@@ -1657,8 +1670,8 @@ See the *DEBUG* documentation for more details."
                           :href "/css/crow-httpd.css"
                           :type "text/css")
                   (:/link :rel "shortcut icon"
-                          :href "/favicon.ico"
-                          :type "image/x-icon"))
+                          :href "/images/crow-httpd-icon.png"
+                          :type "image/png"))
            (:body
             (:h1 "Crow-HTTPd - An interactively developed server")
             (:/img :src "/images/crow-httpd-logo.png"
@@ -2255,21 +2268,8 @@ See the *DEBUG* documentation for more details."
  "localhost"
  '(("/"
     :redirect "/test")
-
    ("/index.html"
-    :redirect "/test")
-
-   ("/images/crow-httpd-logo.png"
-    :embedded embedded-files:*crow-httpd-logo-png*)
-
-   ("/favicon.ico"
-    :embedded embedded-files:*favicon-ico*)
-
-   ("/images/valid-xhtml.png"
-    :embedded embedded-files:*valid-xhtml-png*)
-
-   ("/css/crow-httpd.css"
-    :embedded embedded-files:*crow-httpd-css*)))
+    :redirect "/test")))
 
 
 ;;; XXX We should probably remove this for use as a library
index 9995505..cc83998 100644 (file)
@@ -1,4 +1,4 @@
-;;;; $Id: test-applications.lisp,v 1.10 2012/09/27 02:01:35 mmondor Exp $
+;;;; $Id: test-applications.lisp,v 1.11 2012/09/27 03:13:48 mmondor Exp $
 
 #|
 
@@ -45,7 +45,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (in-package :test-applications)
 
 (defparameter *rcsid*
-  "$Id: test-applications.lisp,v 1.10 2012/09/27 02:01:35 mmondor Exp $")
+  "$Id: test-applications.lisp,v 1.11 2012/09/27 03:13:48 mmondor Exp $")
 
 
 ;;; Helper functions
@@ -124,6 +124,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
        (:/link :rel "stylesheet"
               :href "/css/crow-httpd.css"
               :type "text/css")
+       (:/link :rel "shortcut icon"
+              :href "/images/crow-httpd-icon.png"
+              :type "image/png")
        (:title "Share your comments"))
       (:body :style "height: 99%"
             (:table :width "100%" :style "height: 99%"
@@ -363,6 +366,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
             (:/link :rel "stylesheet"
                     :href "/css/crow-httpd.css"
                     :type "text/css")
+            (:/link :rel "shortcut icon"
+                    :href "/images/crow-httpd-icon.png"
+                    :type "image/png")
             (:title "Suggest a name for this HTTPd"))
            (:body
             (:h1 "Suggest a name for this HTTPd")
@@ -448,6 +454,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
        (:html (:head (:/link :rel "stylesheet"
                             :href "/css/crow-httpd.css"
                             :type "text/css")
+                    (:/link :rel "shortcut icon"
+                            :href "/images/crow-httpd-icon.png"
+                            :type "image/png")
                     (:title title))
              (:body
               (:a :href "/names" "&lt;- Back")