updated *upload-filename-generator implementation

doc/index.xml

@@ -1751,12 +1751,12 @@
 
       <clix:special-variable name='*upload-filename-generator*'>
         <clix:description>
-         A filename designator for the uploaded file being written
-         to disk. It defaults to <code>NIL</code> in which case the internal
-         filename generator will be used. It also can be a <code>STRING</code> 
-         of the filename, a <code>PATHNAME</code>, or a <code>SYMBOL</code> 
-         which should be a function without arguments that returns the
-         filename <code>STRING</code>.
+         This is used to control how filename generation for the files being uploaded.
+         It defaults to <code>NIL</code> in which case the internal filename 
+         generator will be used. It can also be a <code>SYMBOL</code> (designating
+         a function) or a <code>Function</code>, in both cases the function should
+         have signature of (&key file-name field-name content-type), and should
+         return a filename to be used by the server to which uploaded content is written.
         </clix:description>
       </clix:special-variable>
 

request.lisp

@@ -124,7 +124,7 @@ supposed to be of content type 'multipart/form-data'."
                              "BOUNDARY"
                              (rfc2388:header-parameters parsed-content-type-header)))
 		       (return-from parse-rfc2388-form-data))))
-    (loop for part in (rfc2388:parse-mime stream boundary :write-content-to-file (make-upload-filename))
+    (loop for part in (rfc2388:parse-mime stream boundary :write-content-to-file (make-upload-filename-generator))
           for headers = (rfc2388:mime-part-headers part)
           for content-disposition-header = (rfc2388:find-content-disposition-header headers)
           for name = (cdr (rfc2388:find-parameter

specials.lisp

@@ -254,11 +254,13 @@ the debugger).")
   "A list of temporary files created while a request was handled.")
 
 (defparameter *upload-filename-generator* nil
-  "A filename designator to be used by RFC2388 when uploaded file
-   is being written to disk. It defaults to NIL in which case the
-   internal generator is used. It also can be a STRING of the filename,
-   a PATHNAME, or a SYMBOL which should be a function that takes no
-   arguments and return the filename")
+  "This is used to control how filename generation for the files
+being uploaded. It defaults to NIL in which case the internal
+filename generator will be used. It can also be a SYMBOL (designating
+a function) or a Function, in both cases the function should have
+signature of (&key file-name field-name content-type), and should
+return a filename to be used by the server to which uploaded content
+is written.")
 
 (defconstant +latin-1+
   (make-external-format :latin1 :eol-style :lf)

util.lisp

@@ -128,9 +128,8 @@ according to HTTP/1.1 \(RFC 2068)."
 (let ((counter 0))
   (declare (ignorable counter))
   (defun make-tmp-file-name (&optional (prefix "hunchentoot"))
-    "Generates a unique name for a temporary file.  When
-    *upload-filename-generator* is NIL, then this is the default
-     function supplied to RFC2388 library when a file is uploaded."
+    "Generates a unique name for a temporary file.  This function is
+called from the RFC2388 library when a file is uploaded."
     (let ((tmp-file-name
            #+:allegro
            (pathname (system:make-temp-file-name prefix *tmp-directory*))
@@ -142,23 +141,27 @@ according to HTTP/1.1 \(RFC 2068)."
                  unless (probe-file pathname)
                  return pathname)))
       (push tmp-file-name *tmp-files*)
+      ;; maybe call hook for file uploads
+      (when *file-upload-hook*
+        (funcall *file-upload-hook* tmp-file-name))
       tmp-file-name)))
 
-(defun make-upload-filename ()
-  "This function is used to generate the filename to
-   be passed to RFC2388 library. There it will be used
-   for the content being written to the disk."
-  (let ((filename (cond
-                   ((null *upload-filename-generator*)
-                     (funcall 'make-tmp-file-name))
-                   (otherwise
-                    (etypecase *upload-filename-generator*
-                      (string *upload-filename-generator*)
-                      (pathname (namestring *upload-filename-generator*))
-                      (symbol (funcall *upload-filename-generator*))))))) ;
-    (when *file-upload-hook*
-      (funcall *file-upload-hook* filename))
-    filename))
+(defun make-upload-filename-generator ()
+  "Based on the value of *upload-filename-generator*, arrange
+for a suitable filename generator to be used by RFC2388 library
+when a file is being uploaded."
+  (etypecase *upload-filename-generator* 
+    ;; the old behaviour.
+    (null (lambda (&rest args)
+            (declare (ignore args))
+            (funcall #'make-tmp-file-name)))
+    ;; the new additional behaviour.
+    ((or symbol function) 
+     (lambda (&rest args)
+       (let ((filename (apply *upload-filename-generator* args :allow-other-keys t)))
+         (when *file-upload-hook*
+           (funcall *file-upload-hook* filename))
+         filename)))))
 
 (defun quote-string (string)
   "Quotes string according to RFC 2616's definition of `quoted-string'."