[tbnl-devel] Serving static files

[Bob Hutchison]

Hi,

I have implemented a handler for serving static files using TBNL. I 
ended up doing this differently than I expected. I extended 
create-prefix-dispatcher and called it create-prefix-dispatcher/2 and a 
little macro, prefix-dispatcher/2, to simplify things a bit. 
create-prefix-dispatcher/2 does everything that 
create-prefix-dispatcher does (in the same way) and is intended to be a 
drop-in replacement.

create-prefix-dispatcher/2 looks at its page-function argument and 
handles symbols exactly as create-prefix-dispatcher did, but cons are 
handled differently.

When create-prefix-dispatcher/2 encounters a page function that is a 
cons it assumes that it is a lambda with one argument that returns a 
lambda of no arguments. create-prefix-dispatcher/2 uses gensym to 
generate a symbol for the function then setfs its symbol-function to 
the lambda returned by (funcall (eval page-function) prefix). The 
generated symbol is then handled exactly as though that symbol was 
passed in as page-function. This seems a bit awkward to me, but it 
works.

The static-directory/*-handler takes 4 arguments:
prefix -- the url prefix that matched the script-name. When this is 
removed from the
           front of the script-name, we are left with the path relative 
to the
           directory-path of the file requested.
directory-path -- the root directory of the files to be served
default-type -- the default mime-type (can be nil)
file-type-map -- an assoc list of file name extensions (e.g. ".gif") 
and a mime type.

If the content-type cannot be determined it is not set (maybe not the 
best idea, but...)

I've not been able to test this on anything other that LWM using OS/X 
10.3.9 -- so only tbnl-bivalent-streams has been tested at all.

Sorry, the documentation is a bit weak.

There is an example near the end of how to use this stuff.

Hope somebody finds this useful.

Cheers,
Bob

-------

(defun static-directory/*-handler (prefix directory-path default-type 
file-type-map)
"A TBNL handler that will serve static files located relative
to a directory.

'prefix' is what TBNL matched to the script-name (this match provided
the excuse to call this handler). If we remove the prefix from the
front of the script-name we get the path, relative to 'directory-path',
that identifies the file.

'default-type' is the default mime-type for the file, nil is okay.

'file-type-map' is an assoc list of file extensions and mime types.
"
   (labels ((determine-content-type (relative-file-path)
              (or (cdr (find-if (lambda (pair) (zerop (mismatch (car 
pair) relative-file-path :from-end t)))
                                file-type-map))
                  default-type)))
     (let* ((script-name (script-name))
            (relative-file-path (subseq script-name (mismatch prefix 
script-name)))
            (path (concatenate 'string directory-path 
relative-file-path))
            (time (or (file-write-date path)
                      (get-universal-time)))
            (content-type (determine-content-type relative-file-path)))
       (when content-type (setf (content-type) content-type))
       (unless (probe-file path)
         (setf (return-code) +http-not-found+)
         (throw 'tbnl-handler-done nil))
       #+:tbnl-bivalent-streams
       (progn
         (handle-if-modified-since time)
         (with-open-file (file path
                               :direction :input
                               :element-type '(unsigned-byte 8)
                               :if-does-not-exist nil)
           (let* ((len (file-length file))
                  (buf (make-array len :element-type '(unsigned-byte 
8))))
             (read-sequence buf file)
             (setf (header-out "Last-Modified") (rfc-1123-date time))
             buf)))
       #-:tbnl-bivalent-streams
       (let ((buf (make-array 8192
                              :element-type 'character)))
         (handle-if-modified-since time)
         (let ((str
                (with-output-to-string (out)
                  (with-open-file (file path
                                        :direction :input
                                        :if-does-not-exist nil)
                     (loop for pos = (read-sequence buf file)
                          until (zerop pos)
                          do (write-sequence buf out :end pos))))))
           (setf (header-out "Last-Modified") (rfc-1123-date time))
           str)))))

(defmacro prefix-dispatcher/2 (fn &rest args)
   "construction a function with one argument, prefix, that
returns a function of no arguments that calls fn with prefix
as the first argument followed by the args."
   `(lambda (prefix)
      (lambda ()
        (,fn prefix , at args))))

(defun create-prefix-dispatcher/2 (prefix page-function)
   "Creates a dispatch function which will dispatch to the
function denoted by PAGE-FUNCTION if the file name of the current
request starts with the string PREFIX. This is exactly what
create-prefix-dispatcher does. However, if page-function is a cons,
then it must be of the form:
     (lambda (prefix) (lambda () ...))
This lambda serves as the page function."

   (when (consp page-function)
     (let ((fn (gensym "handler"))
           (fv (funcall (eval page-function) prefix)))
       (setf (symbol-function fn) fv)
       (setf page-function fn)))
   (lambda (request)
     (let ((mismatch (mismatch (script-name request) prefix
                               :test #'char=)))
       (and (or (null mismatch)
                (>= mismatch (length prefix)))
            page-function))))

(setq *dispatch-table*
       (nconc
        (mapcar (lambda (args)
                  (apply #'create-prefix-dispatcher/2 args))
                '(("/sienna/image/" (prefix-dispatcher/2 
static-directory/*-handler
                                                         "images/"
                                                         nil
                                                         '((".jpg" . 
"image/jpeg")
                                                           (".jpeg" . 
"image/jpeg")
                                                           (".gif" . 
"image/gif"))))
                  ("/sienna/images/" (prefix-dispatcher/2 
static-directory/*-handler
                                                          "images/"
                                                          nil
                                                          '((".jpg" . 
"image/jpeg")
                                                            (".jpeg" . 
"image/jpeg")
                                                            (".gif" . 
"image/gif"))))
                  ("/sienna/css/" (prefix-dispatcher/2 
static-directory/*-handler
                                                       "css/"
                                                       nil
                                                       '((".js" . 
"text/javascript")
                                                         (".css" . 
"text/css")
                                                         (".gif" . 
"image/gif"))))
                  ("/sienna/item/" show-item)))
        (list #'default-dispatcher)))