csw-upload

The file upload CGI script. It is a preliminary version, probably has bugs and misfeatures. There are two files: csw-upload.scm which implements the functionality as a module, and the cgi-script itself, upload.

 ;;; 
 ;;; csw-upload.scm 
 ;;; 
 ;;;  Copyright (c) 2004 Grzegorz Chrupała 
 ;;;  This code is under the same license as Gauche itself 
  
 (define-module csw-upload 
   (use www.cgi) 
   (use text.html-lite) 
   (use sxml.tools) 
   (use text.tree) 
   (use gauche.parameter) 
   (use file.util) 
   (use srfi-13) 
   (use dbm) 
   (export   output-charset   upload-path   url-prefix 
    temp-path   stylesheet   cmd-upload   cmd-delete 
    cmd-list   cmd-search   cmd-save   upload-part-handlers) 
   ) 
 (select-module csw-upload) 
  
 (use dbm.gdbm) 
  
  
 ;; customization parameters 
 (define output-charset (make-parameter "UTF-8")) 
 (define upload-path    (make-parameter "/var/www/html/wiliki-upload")) 
 (define db-path        (make-parameter "/var/www/data/wiliki-upload")) 
 ;; we use a separate database, not wiliki's one 
 (define db-type        (make-parameter <gdbm>)) 
 (define url-prefix     (make-parameter "/wiliki-upload")) 
 (define temp-path      (make-parameter "/var/www/html/wiliki-upload/tmp")) 
 (define stylesheet     (make-parameter "/scheme.css")) 
 (define action (make-parameter "/cgi-bin/upload")) 
  
 (define *tmp-prefix* (build-path (temp-path) "wilikiupload")) 
 (define $$ values) ;; for now ignore gettext 
  
  
 ;;; Helper definitions 
 (define-syntax aif  
   (syntax-rules ()  
     ;; simple version  
     ((aif var expr iftrue iffalse)  
      (let ((var expr))  
        (if var  
            iftrue  
            iffalse)))  
     ;; version with a test procedure  
     ((aif var test expr iftrue iffalse)  
      (let ((var expr))  
        (if (test var)  
            iftrue  
            iffalse)))))  
  
 ;; ======= DB facilities : slightly adapted from wiliki.db =================== 
 ;; I don't simply use wiliki-with-db as we need to specify the value conversion 
 ;; procedure for the db. Alternatively wiliki/db.scm could be patched so 
 ;; wiliki-with-db accepts optional conversion procedures 
  
 ;; For this chunk of code: 
 ;; Copyright (c) 2003-2004 Shiro Kawai, All rights reserved. 
  
 ;; some constants 
 (define-constant *retry-limit* 3) 
 (define-constant *EAVAIL-message* "resource temporarily unavailable") 
  
 (define the-db (make-parameter #f)) 
  
  
 (define (db-try-open dbpath dbtype rwmode ) 
   ;; Try to open the database.  If it receives EAVAIL error, wait for 
   ;; one second and try again, up to *retry-limit* times. 
   (define (try retry mode) 
     (with-error-handler 
         (lambda (e) 
           (cond ((>= retry *retry-limit*) (raise e)) 
                 ((string-contains-ci (ref e 'message) *EAVAIL-message*) 
                  (sys-sleep 1) (try (+ retry 1) mode)) 
                 (else 
                  ;; we don't want to show the path of db to unknown 
                  ;; visitors 
                  (raise 
                   (make <error> :message #`"Couldn't open database file to ,|rwmode|."))))) 
       (lambda () 
         (dbm-open dbtype 
                   :path dbpath  
                   :rw-mode mode 
                   :value-convert `(,write-to-string ,read-from-string))))) 
  
   ;; If db file does not exist, we open it with :write mode, 
   ;; regardless of rwmode arg, so that the empty DB is created. 
   ;; Note that race condition will not happen here.  If there's no 
   ;; DB and two process simultaneously came to this code, only 
   ;; one can grab the write access of DB, and another will 
   ;; be kept waiting until the initial content is committed. 
   (try 0 (if (dbm-db-exists? dbtype dbpath) rwmode :write)) 
   ) 
  
 (define (check-db) 
   (or (the-db) 
       (error "WiLiKi uploads: database is not open"))) 
  
  
 (define (with-db thunk . opts) 
   (let-keywords* opts ((rwmode :read)) 
     (if (the-db) 
       (thunk) 
       (parameterize ((the-db (db-try-open (db-path) (db-type) rwmode))) 
         (dynamic-wind 
          (lambda () #f) 
          thunk 
          (lambda () 
            (unless (dbm-closed? (the-db)) 
              (dbm-close (the-db))))))))) 
  
 ;;;; ========================================================================= 
  
  
 (define-class <upload-file> () 
   ((name        :init-keyword :name)          ;; filename  
    (title       :init-keyword :title)         ;; name for display 
    (submitter   :init-keyword :submitter)     ;; person who contributed file 
    (description :init-keyword :description)))  ;; additional information 
  
 (define-reader-ctor (class-name <upload-file>) 
   (lambda (name title submitter description) 
     (make <upload-file> 
       :name        name 
       :title       title 
       :submitter   submitter 
       :description description))) 
  
 (define-method write-object ((self <upload-file>) (port <port>)) 
   (format port "#,(~s ~s ~s ~s ~s)" 
           (class-name <upload-file>) 
           (slot-ref self 'name) 
           (slot-ref self 'title) 
           (slot-ref self 'submitter) 
           (slot-ref self 'description))) 
  
       
 (define (html-page page pagename) 
   (define upload-url "?command=upload") 
   (define list-url   "?command=list") 
   `("Content-Style-Type: text/css\n" 
     ,(cgi-header 
       :content-type #`"text/html; charset=,(output-charset)") 
     ,(html-doctype :type :transitional) 
     ,(sxml:sxml->xml 
       `(html (head (title ,pagename) 
                   (link (@ (rel stylesheet) 
                            (type text/css) 
                            (url ,(stylesheet))))) 
              (body 
               (h1 ,pagename) 
               (div (@ (class upload-menu)) 
                    (a (@ (href ,upload-url)) ,($$ "Upload")) " | " 
                    (a (@ (href ,list-url))   ,($$ "List"))) 
                                 
              ,page))))) 
  
 (define (make-upload-file name param) 
   (make <upload-file> 
     :name          name  
     :title         (aif title string-null? 
                         (cgi-get-parameter "upload-file-title" param 
                                       :default "") 
                         name 
                         title) 
     :submitter     (aif submitter string-null? 
                         (cgi-get-parameter "upload-file-submitter"   param 
                                       :default "") 
                         (cgi-get-metavariable "REMOTE_ADDR") 
                         submitter) 
     :description   (cgi-get-parameter "upload-file-description" param 
                                            :default ""))) 
                          
  
 (define (cmd-upload param) 
   (html-page (upload-form) ($$ "CSW - File upload"))) 
  
  
 (define (cmd-delete param) 
   (let1 key (cgi-get-parameter "upload-file-name" param :default #f) 
     (unless key (error "No file for deletion specified")) 
     (with-db 
      (lambda () 
        (dbm-delete! (the-db) key) 
        (if (sys-unlink (build-path (upload-path) key)) 
            (html-page (list-files values) ($$ "CSW - File deleted")) 
            (html-page (list-files values) ($$ #`"CSW - File does not exists: ,key")))) 
        :rwmode :write))) 
      
  
  
 (define (cmd-save param) 
   (let ((source-name (cgi-get-parameter "upload-file-contents" 
                                         param 
                                         :default #f)) 
         (target-name (get-file-name (cgi-get-parameter "upload-file-name" 
                                                        param 
                                                        :default #f)))) 
     (unless source-name  
       (error "Source name of file to copy not given: " source)) 
     (unless target-name 
       (error "Target name of file to copy not given: " target)) 
     ;; create upload directory if it doesn't exist 
     (make-directory* (upload-path)) 
     (let1 upload-file (make-upload-file target-name param) 
       (save-file upload-file 
                  source-name 
                  (build-path (upload-path) target-name)) 
       (html-page (list-files values) 
                  ($$ "CSW - File saved"))))) 
  
 (define (cmd-list param) 
   (html-page (list-files values) 
              ($$ "CSW - Listing of uploaded files"))) 
  
 (define (cmd-search param) 
   (html-page (list-files (create-filter param)) 
                          ($$ "CSW - Search results"))) 
  
 (define (create-filter param) 
   (let ((name         (cgi-get-parameter "upload-file-name"        param :default "")) 
         (title        (cgi-get-parameter "upload-file-title"       param :default "")) 
         (submitter    (cgi-get-parameter "upload-file-submitter"   param :default "")) 
         (description  (cgi-get-parameter "upload-file-description" param :default ""))) 
     (lambda (fileinfo) 
       (and (string-contains-ci (slot-ref fileinfo 'name)        name) 
            (string-contains-ci (slot-ref fileinfo 'title)       title) 
            (string-contains-ci (slot-ref fileinfo 'submitter)   submitter) 
            (string-contains-ci (slot-ref fileinfo 'description) description))))) 
  
 (define (save-file upload-file source-name target-name) 
     ; this should alert the user when they are about to overwrite a file 
   (with-db 
    (lambda () 
      (dbm-put! (the-db) 
                (slot-ref upload-file 'name) upload-file) 
      (copy-file source-name target-name :if-exists :backup)) 
    :rwmode :write 
    )) 
                                                
 ;;better ways to sanitize user-provided file names welcome 
 (define (sanitize string) 
   (regexp-replace-all #/^\.+|[^a-zA-Z0-9 \-_\.]/ string "_")) 
  
 (define (get-file-name form-name) 
   (if (and (string? form-name) 
            (not (string-null? form-name))) 
       (sanitize form-name) 
       (sys-strftime "%Y-%m-%d-%T" (sys-gmtime (sys-time))))) 
  
 (define (upload-part-handlers) 
   `(("upload-file-contents" file ,*tmp-prefix*))) 
  
 (define (upload-form) 
   `((form 
      (@ (action ,(action)) (method POST) (enctype "multipart/form-data") 
         (id file-upload-form)) 
      (input (@ (type hidden) (name command) (value save))) 
      (div ,($$ "Choose file") 
           (br) 
           (input (@ (type file) (name upload-file-contents)))) 
      (div 
       ,($$ "Name (file will be saved under this name)") 
       (br) 
       (input (@ (type text) (name upload-file-name)))) 
      (div 
       ,($$ "Title") 
       (br) 
       (input (@ (type text) (name upload-file-title)))) 
      (div 
       ,($$ "Uploaded by") 
       (br) 
       (input (@ (type text) (name upload-file-submitter)))) 
      (div 
       ,($$ "Description") 
       (br) 
       (textarea (@ (class "upload-file-description") 
                    (name upload-file-description)) 
                 "")) 
      (input (@ (type submit)))))) 
  
 (define (list-files filterer) 
   `((h2 ,($$ "Search files")) 
     (div (@ (class upload-file-search-form)) 
          (form (@ (method "GET") (action ,(action)) (class file-upload-search)) 
                (input (@ (type hidden) (name command) (value search))) 
                (table (@ (class file-upload-search)) (tr 
                        (th ,($$ "Name: ")) 
                        (th ,($$ "Title:  ")) 
                        (th ,($$ "Uploaded by: ")) 
                        (th ,($$ "Description: "))) 
                       (tr 
                        (td 
                         (input (@ (type text) (name upload-file-name)))) 
                        (td 
                         (input (@ (type text) (name upload-file-title)))) 
                        (td 
                         (input (@ (type text) (name upload-file-submitter)))) 
                        (td 
                         (input  (@ (type text) (name upload-file-description)))))) 
                (input (@ (type submit) (value ,($$ "Search")))))) 
     (h2 ,($$ "Files found:")) 
     (ul (@ (class "file-list")) 
         ,@(map file-list-item (get-file-list filterer))))) 
  
 (define (get-file-list filterer) 
   (with-db 
    (lambda () 
      (sort (dbm-fold (the-db) 
                (lambda (key fileinfo seed) 
                  (if (filterer fileinfo) 
                      (cons fileinfo seed) 
                      seed)) '()) 
            (lambda (f1 f2) 
              (string-ci<? (slot-ref f1 'title) (slot-ref f2 'title)))) 
            ))) 
  
 (define (file-list-item fileinfo) 
   `(li (@ (class file-list-item) 
           (id ,(string-append "file-" (slot-ref fileinfo 'name)))) 
        (div (@ (class file-title)) 
             (a (@ (href ,(build-path (url-prefix) (slot-ref fileinfo 'name)))) 
                ,(slot-ref fileinfo 'title))) 
  
        (div (@ (class file-submitter)) ,(slot-ref fileinfo 'submitter)) 
        (div (@ (class file-description)) 
             ,(slot-ref fileinfo 'description)) 
        (form (@ (action ,(action)) (method "POST")) 
              (input (@ (type hidden) 
                        (name command) 
                        (value delete))) 
              (input (@ (type hidden) 
                        (name upload-file-name) 
                        (value ,(slot-ref fileinfo 'name)))) 
              (input (@ (type submit) 
                        (value ,($$ "Delete"))))))) 
  
 (provide "csw-upload") 
  

-----

 #!/usr/local/bin/gosh 
  
 ;;; 
 ;;; upload 
 ;;; 
 ;;;  Copyright (c) 2004 Grzegorz Chrupała 
 ;;;  This code is under the same license as Gauche itself 
  
 (add-load-path ".") 
 (use www.cgi) 
 (use csw-upload) 
  
 ;;; Customize parameters here 
  
 (cgi-main 
  (lambda (param) 
    (let1 command (string->symbol (cgi-get-parameter "command" param :default "")) 
      (case command 
        ((list)    (cmd-list   param)) 
        ((upload)  (cmd-upload param)) 
        ((save)    (cmd-save   param)) 
        ((search)  (cmd-search param)) 
        ((delete)  (cmd-delete param)) 
        (else      (cmd-list param))))) 
  :merge-cookies #t 
  :part-handlers (upload-part-handlers)) 
  

category-this-wiki