Added some user utility functions and macros from MASH.

src/main/utility.cl

@@ -0,0 +1,69 @@
+;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
+;;;; This is copyrighted software.  See documentation for terms.
+;;;; 
+;;;; utility.cl --- Utility functions and macros for CLASH users
+;;;; 
+;;;; Checkout Tag: $Name$
+;;;; $Id$
+
+(in-package :CLASH)
+
+;;;; %File Description:
+;;;; 
+;;;; 
+;;;; 
+
+(defun pathname-filename (p)
+  (concatenate 'string (pathname-name p) "." (pathname-type p)))
+
+(defun export-files (server type base &rest files)
+  "Export all the given files as static resources from the given base.
+The files content-type is type and the files are exported as a
+file-entity."
+  (dolist (file files)
+    (export-resource
+     server
+     (merge-urls (make-instance 'url-http :name (pathname-filename file))
+		 base)
+     'static-resource
+     :entity
+     (make-instance 'file-entity :content-type type :pathname file))))
+
+(defun export-directory (server type-map base directory &optional recursive-p)
+  "Export the contents of a directory."
+  (flet ((lookup-type (type)
+	   (or (cdr (assoc type type-map :test #'equal))
+	       (cdr (assoc t type-map :test #'equal)))))
+    (dolist (file (directory directory))
+      (if (null (pathname-name file))
+	  (when recursive-p
+	    (export-directory
+	     server type-map
+	     (merge-urls
+	      (make-instance
+	       'url-http
+	       :directory (list* :relative (last (pathname-directory file))))
+	      base)
+	     file
+	     recursive-p))
+	  (export-resource
+	   server
+	   (merge-urls
+	    (make-instance 'url-http :name
+			   (concatenate 'string (pathname-name file)
+					"." (pathname-type file)))
+	    base)
+	   'static-resource
+	   :entity
+	   (make-instance 'file-entity
+			  :content-type (lookup-type (pathname-type file))
+			  :pathname file))))))
+
+(defmacro with-string-response
+    (((stream request code &rest r-args) &rest e-args) &body body)
+  `(create-response ,request ,code ,@r-args
+                    :entity
+	            (make-instance 'string-entity ,@e-args
+		                   :body
+		                   (with-output-to-string (,stream)
+				     ,@body))))