Changeset 2660

Show
Ignore:
Timestamp:
03/05/08 13:04:56 (10 months ago)
Author:
hans
Message:

Fix file uploads with Hunchentoot

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/bknr/web/src/images/image-handlers.lisp

    r2650 r2660  
    8080                        (action (eql :upload))) 
    8181  (with-bknr-page (:title "Image upload result") 
    82     (let ((file-pathname (cdr (find "file" (request-uploaded-files) :key #'car :test #'equal)))) 
    83       (unless file-pathname 
     82    (let ((upload (request-uploaded-file "file"))) 
     83      (unless upload 
    8484        (error "no file uploaded")) 
    8585      (with-query-params (name keyword) 
    86         (let* ((image (import-image file-pathname 
    87                                    :user (bknr-session-user) 
    88                                    :keywords (list keyword) 
    89                                    :keywords-from-dir nil)) 
     86        (let* ((image (bknr.images:import-image upload 
     87                                                :user (bknr-session-user) 
     88                                                :keywords (when keyword (list keyword)) 
     89                                                :keywords-from-dir nil)) 
    9090               (image-id (store-object-id image))) 
    9191          (if image 

  • trunk/bknr/web/src/images/image.lisp

    r2522 r2660  
    105105 
    106106;;; import 
    107 (defun import-image (pathname &key name user keywords directory (keywords-from-dir t) (class-name 'store-image) initargs) 
    108   "Create blob from given file" 
    109   (unless name 
    110     (setq name (pathname-name pathname))) 
    111   (unless (scan #?r"\D" name) 
    112     (error "invalid image name ~A, needs to contain at least one non-digit character" name)) 
    113   (when (store-image-with-name name) 
    114     (error "can't import image with name ~A, an image with this name already exists in the datastore" name)) 
    115   (with-image-from-file (image pathname) 
    116     ;; xxx not tx safe.  hm. 
    117     (let ((store-image (apply #'make-object  
    118                               (append (list class-name 
    119                                             :owners (list user) 
    120                                             :timestamp (get-universal-time) 
    121                                             :name name 
    122                                             :type (pathname-type-symbol pathname) 
    123                                             :width (image-width image) 
    124                                             :height (image-height image) 
    125                                             :directory directory 
    126                                             :keywords (if keywords-from-dir 
    127                                                           (append (mapcar #'make-keyword-from-string directory) keywords) 
    128                                                           keywords)) 
    129                                       initargs)))) 
    130       (blob-from-file store-image pathname) 
    131       store-image))) 
     107(defgeneric import-image (pathname &key type name user keywords directory keywords-from-dir class-name initargs) 
     108  (:documentation "Create blob from given source") 
     109  (:method (pathname &key type name user keywords directory (keywords-from-dir t) (class-name 'store-image) initargs) 
     110    (unless name 
     111      (setq name (pathname-name pathname))) 
     112    (unless (scan #?r"\D" name) 
     113      (error "invalid image name ~A, needs to contain at least one non-digit character" name)) 
     114    (when (store-image-with-name name) 
     115      (error "can't import image with name ~A, an image with this name already exists in the datastore" name)) 
     116    (let ((type (or type (pathname-type pathname)))) 
     117      (unless (keywordp type) 
     118        (setf type (make-keyword-from-string type))) 
     119      (with-image-from-file (image pathname type) 
     120        ;; xxx not tx safe. 
     121        (let ((store-image (apply #'make-object  
     122                                  (append (list class-name 
     123                                                :owners (list user) 
     124                                                :timestamp (get-universal-time) 
     125                                                :name name 
     126                                                :type (make-keyword-from-string type) 
     127                                                :width (image-width image) 
     128                                                :height (image-height image) 
     129                                                :directory directory 
     130                                                :keywords (if keywords-from-dir 
     131                                                              (append (mapcar #'make-keyword-from-string directory) keywords) 
     132                                                              keywords)) 
     133                                          initargs)))) 
     134          (blob-from-file store-image pathname) 
     135          store-image))))) 
    132136 
    133137(defun directory-recursive (pathname &key list-directories) 

  • trunk/bknr/web/src/packages.lisp

    r2650 r2660  
    227227           #:upload-name 
    228228           #:upload-pathname 
     229           #:upload-original-filename 
    229230           #:upload-size 
    230231           #:upload-content-type 
     232 
     233           #:with-image-from-upload 
     234           #:with-image-from-upload* 
    231235 
    232236           #:bknr-url-path 

  • trunk/bknr/web/src/web/handlers.lisp

    r2656 r2660  
    265265                                                             (do-error-log-request e))))))) 
    266266               (handle handler)) 
    267              (handle handler)) 
    268       (handler-case 
    269           (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files))) 
    270         (error (e) 
    271           (warn "error ~A ignored while deleting uploaded files" e)))))) 
     267             (handle handler))))) 
    272268 
    273269(defmethod handle ((page-handler page-handler)) 

  • trunk/bknr/web/src/web/web-utils.lisp

    r2639 r2660  
    33(enable-interpol-syntax) 
    44 
    5 (defstruct upload name pathname content-type) 
     5(defstruct upload name pathname original-filename content-type) 
    66 
    77(defgeneric object-url (obj)) 
    …… 
    2121                 :query (uri-query uri))) 
    2222 
    23 #+(or) 
    24 (defun get-multipart-form-data () 
    25   (unless (aux-request-value 'multipart-parsed) 
    26     (let (parameters 
    27           uploaded-files 
    28           file-size-limit-reached) 
    29       (loop 
    30        (multiple-value-bind (kind part-name file-name content-type) 
    31            (parse-multipart-header (get-multipart-header request)) 
    32          (case kind 
    33            (:eof (return)) 
    34            (:data (push (cons part-name (get-all-multipart-data request)) parameters)) 
    35            (:file (let ((contents (get-all-multipart-data request 
    36                                                           :type :binary 
    37                                                           :limit *upload-file-size-limit*)) 
    38                         (file-basename (regex-replace #?r".*[\\/]" file-name ""))) 
    39                     (cond 
    40                       ((eq contents :limit) 
    41                        (setf file-size-limit-reached t)) 
    42                       ((equal file-name "") 
    43                        (warn "Can't parse file name from uploaded file named ~a, file ignored" file-name)) 
    44                       (t 
    45                        (let ((uploaded-file-name (merge-pathnames file-basename (store-blob-root-tempdir)))) 
    46                          (format t "; writing uploaded file ~a to ~a~%" file-name uploaded-file-name) 
    47                          (ensure-directories-exist (store-blob-root-tempdir)) 
    48                          (with-open-file (temporary-file uploaded-file-name 
    49                                                          :direction :output 
    50                                                          :if-exists :error 
    51                                                          :element-type '(unsigned-byte 8)) 
    52                            (write-sequence contents temporary-file)) 
    53                          (push (make-upload :name part-name :pathname uploaded-file-name 
    54                                             :content-type content-type) uploaded-files)))))) 
    55            (t 
    56             (get-all-multipart-data request :limit *upload-file-size-limit*))))) 
    57       (when file-size-limit-reached 
    58         (error "upload file size limit exceeded")) 
    59       (setf (aux-request-value 'bknr-parsed-body-parameters) parameters) 
    60       (setf (aux-request-value 'uploaded-files) uploaded-files)))) 
    61  
    62 (defun get-urlencoded-form-data () 
    63   (format t "get-urlencoded-form-data not ported~%") 
    64   #+(or) 
    65   (loop for name-value in (form-urlencoded-to-query (get-request-body)) 
    66         do (push name-value (aux-request-value 'bknr-parsed-body-parameters)))) 
    67  
    68 (defun parse-request-body (&key uploads) 
    69   (let ((content-type (header-in :content-type))) 
    70     (cond 
    71       ((null content-type) 
    72        nil) 
    73       ((scan #?r"^(?i)application/x-www-form-urlencoded" content-type) 
    74        (format t "body parameters not parsed~%") 
    75        #+(or) 
    76        (get-urlencoded-form-data request)) 
    77       ((and uploads (scan #?r"^(?i)multipart/form-data" content-type)) 
    78        (format t "uploads not read~%") 
    79        #+(or) 
    80        (get-multipart-form-data))))) 
    81  
    82 (defun request-uploaded-files (&key all-info) 
    83   "Return a list of conses (NAME . PATHNAME) which contains files uploaded by the user. 
    84 If :all-info is non-nil, the full upload file information is returned as a list" 
    85   (format t "request-uploaded-files not yet ported~%") 
    86   (if all-info 
    87       (aux-request-value 'uploaded-files) 
    88       (mapcar (lambda (upload) (cons (upload-name upload) 
    89                                      (upload-pathname upload))) 
    90               (aux-request-value 'uploaded-files)))) 
     23(defun request-uploaded-files () 
     24  "Return a list of UPLOAD structures describing the file uploads in the request." 
     25  (unless (aux-request-value 'uploaded-files) 
     26    (setf (aux-request-value 'uploaded-files) 
     27          (let ((uploads (remove-if-not #'listp (post-parameters) :key #'cdr)) retval) 
     28            (dolist (upload-info uploads) 
     29              (destructuring-bind (name pathname original-filename content-type) upload-info 
     30                (push (make-upload :name name :pathname pathname :original-filename original-filename :content-type content-type) retval))) 
     31            (nreverse retval)))) 
     32  (aux-request-value 'uploaded-files)) 
    9133 
    9234(defun request-uploaded-file (parameter-name) 
    93   (cdr (find parameter-name (request-uploaded-files) :test #'equal :key #'car))) 
     35  (find parameter-name (request-uploaded-files) :test #'equal :key #'upload-name)) 
     36 
     37(defmacro with-image-from-upload ((image upload &rest args) &body body) 
     38  `(with-image-from-file (,image (upload-pathname ,upload) (pathname-type (upload-original-filename ,upload)) ,@args) 
     39    ,@body)) 
     40 
     41(defmacro with-image-from-upload* ((upload &rest args) &body body) 
     42  `(with-image-from-upload (cl-gd:*default-image* ,upload ,@args) 
     43    ,@body)) 
     44 
     45(defmethod bknr.images:import-image ((upload upload) &rest args &key &allow-other-keys) 
     46  (apply #'bknr.images:import-image (upload-pathname upload) 
     47         :name (pathname-name (upload-original-filename upload)) 
     48         :type (make-keyword-from-string (pathname-type (upload-original-filename upload))) args)) 
    9449 
    9550(defun all-request-params () 
    …… 
    10055macro after the request body has been executed." 
    10156  (unless (aux-request-value 'bknr-parsed-parameters) 
    102     (let ((request-charset (or (register-groups-bind (charset) (#?r".*charset=\"?([^\"; ]+).*" (header-in :content-type)) charset) 
    103                                "utf-8"))) 
    104       ;; request-charset is not currently used because there seems to 
    105       ;; be no way to pass the character set for paramter decoding 
    106       ;; down to Hunchentoot.  This will eventually be required (or 
    107       ;; will it?) 
    108       (setf (aux-request-value 'bknr-parsed-parameters) 
    109             (remove "" (query-params) 
    110                     :key #'cdr :test #'string-equal)))) 
     57    (setf (aux-request-value 'bknr-parsed-parameters) 
     58            (remove-if (lambda (value) 
     59                         "Remove empty strings (reported as NIL) and uploaded files" 
     60                         (or (equal value "") 
     61                             (listp value))) 
     62                       (query-params) 
     63                       :key #'cdr))) 
    11164  (aux-request-value 'bknr-parsed-parameters)) 
    11265 
    …… 
    11972    (unless (equal value "") 
    12073      value))) 
    121        
    12274 
    12375(defun query-param-list (param-name &key (get t) (post t)) 

  • trunk/projects/bknr-website/src/init.lisp

    r2652 r2660  
    1414    (import-image (merge-pathnames #p"src/bknr-logo.png" bknr.website.config:*root-directory*) 
    1515                  :keywords '(:banner :bknr)) 
    16     (make-object 'blog 
     16    (make-object 'bknr.text:blog 
    1717                 :name "bknr-devel" 
    1818                 :title "BKNR Website" 

  • trunk/projects/bknr-website/src/webserver.lisp

    r2659 r2660  
    1414                                        ("/admin" admin-handler) 
    1515                                        ("/login" login-handler) 
     16                                        ("/import" import-handler) 
    1617                                        images 
    1718                                        user 

  • trunk/projects/bos/web/allocation-area-handlers.lisp

    r2644 r2660  
    170170 
    171171(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) 
    172   (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car)))) 
     172  (let ((uploaded-text-file (request-uploaded-file "text-file"))) 
    173173    (cond 
    174174      ((not uploaded-text-file) 
    …… 
    177177         (:p "Please upload your text file containing the allocation polygon UTM coordinates"))) 
    178178      (t 
    179        (with-bos-cms-page (:title #?"Importing allocation polygons from text file $(uploaded-text-file)") 
     179       (with-bos-cms-page (:title #?"Importing allocation polygons from uploaded text file") 
    180180         (handler-case 
    181              (let* ((vertices (polygon-from-text-file uploaded-text-file)) 
     181             (let* ((vertices (polygon-from-text-file (upload-pathname uploaded-text-file))) 
    182182                    (existing-area (find (coerce vertices 'list) 
    183183                                                     (class-instances 'allocation-area) 

  • trunk/projects/bos/web/poi-handlers.lisp

    r2644 r2660  
    188188                               (action (eql :upload-airal)) 
    189189                               (poi poi)) 
    190   (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) 
     190  (let ((uploaded-file (request-uploaded-file "image-file"))) 
    191191    (unless uploaded-file 
    192192      (error "no file uploaded in upload handler")) 
    193     (cl-gd:with-image-from-file* (uploaded-file) 
     193    (with-image-from-upload* (uploaded-file) 
    194194      (unless (and (eql (cl-gd:image-width) *poi-image-width*) 
    195195                   (eql (cl-gd:image-height) *poi-image-height*)) 
    …… 
    227227                               (action (eql :upload-panorama)) 
    228228                               (poi poi)) 
    229   (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) 
     229  (let ((uploaded-file (request-uploaded-file "image-file"))) 
    230230    (unless uploaded-file 
    231231      (error "no file uploaded in upload handler")) 
    232     (cl-gd:with-image-from-file* (uploaded-file) 
     232    (with-image-from-upload* (uploaded-file) 
    233233      ; just open the image to make sure that gd can process it 
    234234      ) 
    …… 
    275275  (with-query-params (poi) 
    276276    (setq poi (find-store-object (parse-integer poi) :class 'poi)) 
    277     (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) 
     277    (let ((uploaded-file (request-uploaded-file "image-file"))) 
    278278      (unless uploaded-file 
    279279        (error "no file uploaded in upload handler")) 
    280       (cl-gd:with-image-from-file* (uploaded-file) 
     280      (bknr.web:with-image-from-upload* (uploaded-file) 
    281281        (unless (and (eql (cl-gd:image-width) *poi-image-width*) 
    282282                     (eql (cl-gd:image-height) *poi-image-height*)) 

  • trunk/projects/lisp-ecoop/src/handlers.lisp

    r2438 r2660  
    7575       (with-query-params (info) 
    7676         (format t "; new document - info ~S~%" info) 
    77          (let ((file-name (request-uploaded-file "document"))) 
     77         (let ((file-name (upload-pathname (request-uploaded-file "document")))) 
    7878           (with-open-file (pdf file-name) 
    7979             (if (cl-ppcre:scan "^%PDF-" (read-line pdf)) 

  • trunk/projects/lisp-ecoop/src/tags.lisp

    r2531 r2660  
    5858        (with-query-params (type title abstract info) 
    5959          (format t "; new submission - title ~S abstract ~S~%" title abstract) 
    60           (let ((file-name (request-uploaded-file "document"))) 
     60          (let ((file-name (upload-pathname (request-uploaded-file "document")))) 
    6161            (with-open-file (pdf file-name) 
    6262              (if (cl-ppcre:scan "^%PDF-" (read-line pdf)) 
    …… 
    121121           (return-from submission-editor)))) 
    122122      (when (request-uploaded-file "document") 
    123         (let ((file-name (request-uploaded-file "document"))) 
     123        (let ((file-name (upload-pathname (request-uploaded-file "document")))) 
    124124          (with-open-file (pdf file-name) 
    125125            (cond 

  • trunk/projects/quickhoney/src/handlers.lisp

    r2504 r2660  
    154154(defmethod handle ((handler upload-image-handler)) 
    155155  (with-query-params (client) 
    156     (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car))) 
     156    (let ((uploaded-file (request-uploaded-file "image-file")) 
    157157          (keywords (mapcar #'make-keyword-from-string (decoded-handler-path handler)))) 
    158158      (handler-case 
    …… 
    160160            (unless uploaded-file 
    161161              (error "no file uploaded")) 
    162             (cl-gd:with-image-from-file* (uploaded-file) 
     162            (with-image-from-upload* (uploaded-file) 
    163163              (let* ((color-table (make-hash-table :test #'eql)) 
    164164                     (width (cl-gd:image-width)) 
    …… 
    170170                           (<= (hash-table-count color-table) 256)) 
    171171                  (cl-gd:true-color-to-palette)) 
    172                 (let* ((image (make-store-image :name (pathname-name uploaded-file) 
     172                (let* ((image (make-store-image :name (pathname-name (upload-original-filename uploaded-file)) 
    173173                                                :class-name 'quickhoney-image 
    174174                                                :keywords (cons :upload keywords) 
    …… 
    203203(defmethod handle ((handler upload-animation-handler)) 
    204204  (with-query-params (client) 
    205     (let* ((uploaded-files (request-uploaded-files :all-info t)) 
     205    (let* ((uploaded-files (request-uploaded-files)) 
    206206           (uploaded-image (find "image-file" uploaded-files :test #'equal :key #'upload-name)) 
    207207           (uploaded-animation (find "animation-file" uploaded-files :test #'equal :key #'upload-name))) 
    …… 
    212212            (unless (find (upload-content-type uploaded-animation) '("application/x-shockwave-flash" "video/quicktime" "application/x-director") :test #'equal) 
    213213              (error "Invalid content type ~A - Please upload a Flash, Shockwave or Quicktime file" (upload-content-type uploaded-animation))) 
    214             (cl-gd:with-image-from-file* ((upload-pathname uploaded-image)) 
     214            (with-image-from-upload* (uploaded-image) 
    215215              (let* ((animation-blob (make-blob-from-file (upload-pathname uploaded-animation) 'blob 
    216216                                                          :type (upload-content-type uploaded-animation))) 
    217                      (image (make-store-image :name (pathname-name (upload-pathname uploaded-image)) 
     217                     (image (make-store-image :name (pathname-name (upload-original-filename uploaded-image)) 
     218                                              :type (make-keyword-from-string (pathname-type (upload-original-filename uploaded-image))) 
    218219                                              :class-name 'quickhoney-animation-image 
    219220                                              :keywords (list :upload :pixel :animation) 
    …… 
    247248(defmethod handle ((handler upload-button-handler)) 
    248249  (with-query-params (directory subdirectory) 
    249     (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) 
     250    (let ((uploaded-file (request-uploaded-file "image-file"))) 
    250251      (handler-case 
    251252          (progn 
    …… 
    258259            (unless uploaded-file 
    259260              (error "no file uploaded")) 
    260             (cl-gd:with-image-from-file* (uploaded-file) 
     261            (with-image-from-upload* (uploaded-file) 
    261262              (unless (and (eql 208 (cl-gd:image-width)) 
    262263                           (eql 208 (cl-gd:image-height))) 
    263                 (error "invalid image size, buttons must be 208 by 208 pixels")) 
    264               (let* ((image (make-store-image :name (pathname-name uploaded-file) 
     264                (error "invalid image size, button size must be 208 by 208 pixels")) 
     265              (let* ((image (make-store-image :name (pathname-name (upload-original-filename uploaded-file)) 
     266                                              :type (make-keyword-from-string (pathname-dimensions (upload-original-filename uploaded-file))) 
    265267                                              :class-name 'store-image 
    266268                                              :keywords (list :button