67 lines
1.9 KiB
Common Lisp
67 lines
1.9 KiB
Common Lisp
;;;; 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 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 (file-namestring 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))))
|